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

release
Eduardo Cavazos 2007-11-25 01:18:56 -06:00
commit da91944a68
62 changed files with 2379 additions and 376 deletions

View File

@ -62,6 +62,7 @@ default:
@echo "solaris-x86-64" @echo "solaris-x86-64"
@echo "windows-ce-arm" @echo "windows-ce-arm"
@echo "windows-nt-x86-32" @echo "windows-nt-x86-32"
@echo "windows-nt-x86-64"
@echo "" @echo ""
@echo "Additional modifiers:" @echo "Additional modifiers:"
@echo "" @echo ""
@ -113,6 +114,9 @@ solaris-x86-64:
windows-nt-x86-32: windows-nt-x86-32:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32 $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
windows-nt-x86-64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64
windows-ce-arm: windows-ce-arm:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.arm $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.arm
@ -138,7 +142,7 @@ clean:
rm -f vm/*.o rm -f vm/*.o
vm/resources.o: vm/resources.o:
windres vm/factor.rs vm/resources.o $(WINDRES) vm/factor.rs vm/resources.o
.c.o: .c.o:
$(CC) -c $(CFLAGS) -o $@ $< $(CC) -c $(CFLAGS) -o $@ $<

View File

@ -97,7 +97,9 @@ TUPLE: no-parent-directory path ;
] } ] }
} cond drop ; } cond drop ;
: copy-file ( from to -- ) HOOK: copy-file io-backend ( from to -- )
M: object copy-file
dup parent-directory make-directories dup parent-directory make-directories
<file-writer> [ <file-writer> [
stdio get swap stdio get swap

View File

@ -0,0 +1 @@
Eric Mertens

File diff suppressed because it is too large Load Diff

View File

@ -0,0 +1,64 @@
USING: kernel io io.files splitting strings
hashtables sequences assocs math namespaces prettyprint
math.parser combinators arrays sorting ;
IN: benchmark.knucleotide
: float>string ( float places -- string )
swap >float number>string
"." split1 rot
over length over <
[ CHAR: 0 pad-right ]
[ head ] if "." swap 3append ;
: discard-lines ( -- )
readln
[ ">THREE" head? [ discard-lines ] unless ] when* ;
: read-input ( -- input )
discard-lines
">" read-until drop
CHAR: \n swap remove >upper ;
: tally ( x exemplar -- b )
clone tuck
[
[ [ 1+ ] [ 1 ] if* ] change-at
] curry each ;
: small-groups ( x n -- b )
swap
[ length swap - 1+ ] 2keep
[ >r over + r> subseq ] 2curry map ;
: handle-table ( inputs n -- )
small-groups
[ length ] keep
H{ } tally >alist
sort-values reverse
[
dup first write bl
second 100 * over / 3 float>string print
] each
drop ;
: handle-n ( inputs x -- )
tuck length
small-groups H{ } tally
at [ 0 ] unless*
number>string 8 CHAR: \s pad-right write ;
: process-input ( input -- )
dup 1 handle-table nl
dup 2 handle-table nl
{ "GGT" "GGTA" "GGTATT" "GGTATTTTAATT" "GGTATTTTAATTTATAGT" }
[ [ dupd handle-n ] keep print ] each
drop ;
: knucleotide ( -- )
"extra/benchmark/knucleotide/knucleotide-input.txt" resource-path
<file-reader>
[ read-input ] with-stream
process-input ;
MAIN: knucleotide

View File

@ -0,0 +1,2 @@
The Great Computer Language Shootout's knucleotide benchmark to test
hashtables.

View File

@ -64,7 +64,7 @@ SYMBOL: cols
building get >string building get >string
] with-scope ; ] with-scope ;
: mandel-main ( file -- ) : mandel-main ( -- )
"mandel.ppm" resource-path <file-writer> "mandel.ppm" resource-path <file-writer>
[ mandel write ] with-stream ; [ mandel write ] with-stream ;

View File

@ -49,7 +49,7 @@ IN: benchmark.spectral-norm
HINTS: spectral-norm fixnum ; HINTS: spectral-norm fixnum ;
: spectral-norm-main ( n -- ) : spectral-norm-main ( -- )
2000 spectral-norm . ; 2000 spectral-norm . ;
MAIN: spectral-norm-main MAIN: spectral-norm-main

View File

@ -4,7 +4,7 @@ IN: benchmark.sum-file
: sum-file-loop ( n -- n' ) : sum-file-loop ( n -- n' )
readln [ string>number + sum-file-loop ] when* ; readln [ string>number + sum-file-loop ] when* ;
: sum-file ( file -- n ) : sum-file ( file -- )
<file-reader> [ 0 sum-file-loop ] with-stream . ; <file-reader> [ 0 sum-file-loop ] with-stream . ;
: sum-file-main ( -- ) : sum-file-main ( -- )

View File

@ -58,8 +58,9 @@ SYMBOL: super-sent-messages
"NSSavePanel" "NSSavePanel"
"NSView" "NSView"
"NSWindow" "NSWindow"
"NSWorkspace"
} [ } [
f import-objc-class [ ] import-objc-class
] each ] each
: <NSString> ( str -- alien ) <CFString> -> autorelease ; : <NSString> ( str -- alien ) <CFString> -> autorelease ;

View File

@ -4,7 +4,7 @@ USING: alien alien.c-types alien.compiler
arrays assocs combinators compiler inference.transforms kernel arrays assocs combinators compiler inference.transforms kernel
math namespaces parser prettyprint prettyprint.sections math namespaces parser prettyprint prettyprint.sections
quotations sequences strings words cocoa.runtime io macros quotations sequences strings words cocoa.runtime io macros
memoize ; memoize debugger ;
IN: cocoa.messages IN: cocoa.messages
: make-sender ( method function -- quot ) : make-sender ( method function -- quot )
@ -201,8 +201,11 @@ H{
: import-objc-class ( name quot -- ) : import-objc-class ( name quot -- )
2dup unless-defined 2dup unless-defined
dupd define-objc-class-word dupd define-objc-class-word
dup objc-class register-objc-methods [
objc-meta-class register-objc-methods ; dup
objc-class register-objc-methods
objc-meta-class register-objc-methods
] curry try ;
: root-class ( class -- root ) : root-class ( class -- root )
dup objc-class-super-class [ root-class ] [ ] ?if ; dup objc-class-super-class [ root-class ] [ ] ?if ;

View File

@ -0,0 +1 @@
EditPadPro editor integration

View File

@ -0,0 +1 @@
Emacs editor integration

View File

@ -4,11 +4,7 @@ IN: editors.gvim
TUPLE: gvim ; TUPLE: gvim ;
M: gvim vim-command ( file line -- string ) M: gvim vim-command ( file line -- string )
[ [ "\"" % vim-path get % "\" \"" % swap % "\" +" % # ] "" make ;
"\"" % vim-path get % "\"" %
vim-switches get [ % ] when*
"+" % # " \"" % % "\"" %
] "" make ;
T{ gvim } vim-editor set-global T{ gvim } vim-editor set-global
"gvim" vim-path set-global "gvim" vim-path set-global

View File

@ -0,0 +1 @@
gVim editor integration

View File

@ -0,0 +1 @@
Doug Coleman

View File

@ -0,0 +1,13 @@
USING: editors io.launcher math.parser namespaces ;
IN: editors.notepadpp
: notepadpp ( file line -- )
[
\ notepadpp get-global % " -n" % # " " % %
] "" make run-detached ;
! Put in your .factor-boot-rc
! "c:\\Program Files\\notepad++\\notepad++.exe" \ notepadpp set-global
! "k:\\Program Files (x86)\\notepad++\\notepad++.exe" \ notepadpp set-global
[ notepadpp ] edit-hook set-global

View File

@ -0,0 +1 @@
Notepad++ editor integration

View File

@ -0,0 +1 @@
SciTE editor integration

View File

@ -0,0 +1 @@
Textmate editor integration

View File

@ -0,0 +1 @@
Vim editor integration

28
extra/fjsc/fjsc-tests.factor Normal file → Executable file
View File

@ -4,51 +4,51 @@ USING: kernel tools.test parser-combinators lazy-lists fjsc ;
IN: temporary IN: temporary
{ T{ ast-expression f { T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ { T{ ast-expression f { T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [
"55 2abc1 100" 'expression' parse car parse-result-parsed "55 2abc1 100" 'expression' parse-1
] unit-test ] unit-test
{ T{ ast-quotation f { T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ { T{ ast-quotation f { T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [
"[ 55 2abc1 100 ]" 'quotation' parse car parse-result-parsed "[ 55 2abc1 100 ]" 'quotation' parse-1
] unit-test ] unit-test
{ T{ ast-array f { T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ { T{ ast-array f { T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [
"{ 55 2abc1 100 }" 'array' parse car parse-result-parsed "{ 55 2abc1 100 }" 'array' parse-1
] unit-test ] unit-test
{ T{ ast-stack-effect f { } { "d" "e" "f" } } } [ { T{ ast-stack-effect f { } { "d" "e" "f" } } } [
"( -- d e f )" 'stack-effect' parse car parse-result-parsed "( -- d e f )" 'stack-effect' parse-1
] unit-test ] unit-test
{ T{ ast-stack-effect f { "a" "b" "c" } { "d" "e" "f" } } } [ { T{ ast-stack-effect f { "a" "b" "c" } { "d" "e" "f" } } } [
"( a b c -- d e f )" 'stack-effect' parse car parse-result-parsed "( a b c -- d e f )" 'stack-effect' parse-1
] unit-test ] unit-test
{ T{ ast-stack-effect f { "a" "b" "c" } { } } } [ { T{ ast-stack-effect f { "a" "b" "c" } { } } } [
"( a b c -- )" 'stack-effect' parse car parse-result-parsed "( a b c -- )" 'stack-effect' parse-1
] unit-test ] unit-test
{ T{ ast-stack-effect f { } { } } } [ { T{ ast-stack-effect f { } { } } } [
"( -- )" 'stack-effect' parse car parse-result-parsed "( -- )" 'stack-effect' parse-1
] unit-test ] unit-test
{ } [ { } [
": foo ( a b -- c d ) abcdefghijklmn 123 ;" 'expression' parse car drop ": foo ( a b -- c d ) abcdefghijklmn 123 ;" 'expression' parse car drop
] unit-test ] unit-test
{ T{ ast-expression f { T{ ast-string f "abcd" } } } } [ { T{ ast-expression f { T{ ast-string f "abcd" } } } } [
"\"abcd\"" 'statement' parse car parse-result-parsed "\"abcd\"" 'statement' parse-1
] unit-test ] unit-test
{ T{ ast-expression f { T{ ast-use f "foo" } } } } [ { T{ ast-expression f { T{ ast-use f "foo" } } } } [
"USE: foo" 'statement' parse car parse-result-parsed "USE: foo" 'statement' parse-1
] unit-test ] unit-test
{ T{ ast-expression f { T{ ast-in f "foo" } } } } [ { T{ ast-expression f { T{ ast-in f "foo" } } } } [
"IN: foo" 'statement' parse car parse-result-parsed "IN: foo" 'statement' parse-1
] unit-test ] unit-test
{ T{ ast-expression f { T{ ast-using f { "foo" "bar" } } } } } [ { T{ ast-expression f { T{ ast-using f { "foo" "bar" } } } } } [
"USING: foo bar ;" 'statement' parse car parse-result-parsed "USING: foo bar ;" 'statement' parse-1
] unit-test ] unit-test

148
extra/fjsc/fjsc.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006 Chris Double. All Rights Reserved. ! Copyright (C) 2006 Chris Double. All Rights Reserved.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel lazy-lists parser-combinators parser-combinators.simple USING: kernel lazy-lists parser-combinators parser-combinators.simple
strings promises sequences math math.parser namespaces words strings promises sequences math math.parser namespaces words
quotations arrays hashtables io io.streams.string assocs ; quotations arrays hashtables io io.streams.string assocs ;
IN: fjsc IN: fjsc
@ -53,11 +53,11 @@ C: <ast-hashtable> ast-hashtable
[ CHAR: ] = not ] keep [ CHAR: ] = not ] keep
[ CHAR: ;" = not ] keep [ CHAR: ;" = not ] keep
[ CHAR: " = not ] keep [ CHAR: " = not ] keep
digit? not digit? not
and and and and and ; and and and and and ;
LAZY: 'identifier-ends' ( -- parser ) LAZY: 'identifier-ends' ( -- parser )
[ [
[ blank? not ] keep [ blank? not ] keep
[ CHAR: " = not ] keep [ CHAR: " = not ] keep
[ CHAR: ;" = not ] keep [ CHAR: ;" = not ] keep
@ -67,23 +67,23 @@ LAZY: 'identifier-ends' ( -- parser )
and and and and and and and and and and
] satisfy <!*> ; ] satisfy <!*> ;
LAZY: 'identifier-middle' ( -- parser ) LAZY: 'identifier-middle' ( -- parser )
[ identifier-middle? ] satisfy <!+> ; [ identifier-middle? ] satisfy <!+> ;
LAZY: 'identifier' ( -- parser ) LAZY: 'identifier' ( -- parser )
'identifier-ends' 'identifier-ends'
'identifier-middle' <&> 'identifier-middle' <&>
'identifier-ends' <:&> 'identifier-ends' <:&>
[ concat >string f <ast-identifier> ] <@ ; [ concat >string f <ast-identifier> ] <@ ;
DEFER: 'expression' DEFER: 'expression'
LAZY: 'effect-name' ( -- parser ) LAZY: 'effect-name' ( -- parser )
[ [
[ blank? not ] keep [ blank? not ] keep
CHAR: - = not CHAR: - = not
and and
] satisfy <!+> [ >string ] <@ ; ] satisfy <!+> [ >string ] <@ ;
LAZY: 'stack-effect' ( -- parser ) LAZY: 'stack-effect' ( -- parser )
@ -94,24 +94,24 @@ LAZY: 'stack-effect' ( -- parser )
")" token sp <& [ first2 <ast-stack-effect> ] <@ ; ")" token sp <& [ first2 <ast-stack-effect> ] <@ ;
LAZY: 'define' ( -- parser ) LAZY: 'define' ( -- parser )
":" token sp ":" token sp
'identifier' sp [ ast-identifier-value ] <@ &> 'identifier' sp [ ast-identifier-value ] <@ &>
'stack-effect' sp <!?> <&> 'stack-effect' sp <!?> <&>
'expression' <:&> 'expression' <:&>
";" token sp <& [ first3 <ast-define> ] <@ ; ";" token sp <& [ first3 <ast-define> ] <@ ;
LAZY: 'quotation' ( -- parser ) LAZY: 'quotation' ( -- parser )
"[" token sp "[" token sp
'expression' [ ast-expression-values ] <@ &> 'expression' [ ast-expression-values ] <@ &>
"]" token sp <& [ <ast-quotation> ] <@ ; "]" token sp <& [ <ast-quotation> ] <@ ;
LAZY: 'array' ( -- parser ) LAZY: 'array' ( -- parser )
"{" token sp "{" token sp
'expression' [ ast-expression-values ] <@ &> 'expression' [ ast-expression-values ] <@ &>
"}" token sp <& [ <ast-array> ] <@ ; "}" token sp <& [ <ast-array> ] <@ ;
LAZY: 'word' ( -- parser ) LAZY: 'word' ( -- parser )
"\\" token sp "\\" token sp
'identifier' sp &> [ ast-identifier-value f <ast-word> ] <@ ; 'identifier' sp &> [ ast-identifier-value f <ast-word> ] <@ ;
LAZY: 'atom' ( -- parser ) LAZY: 'atom' ( -- parser )
@ -137,7 +137,7 @@ LAZY: 'USING:' ( -- parser )
";" token sp <& [ <ast-using> ] <@ ; ";" token sp <& [ <ast-using> ] <@ ;
LAZY: 'hashtable' ( -- parser ) LAZY: 'hashtable' ( -- parser )
"H{" token sp "H{" token sp
'expression' [ ast-expression-values ] <@ &> 'expression' [ ast-expression-values ] <@ &>
"}" token sp <& [ <ast-hashtable> ] <@ ; "}" token sp <& [ <ast-hashtable> ] <@ ;
@ -147,14 +147,14 @@ LAZY: 'parsing-word' ( -- parser )
'IN:' <|> ; 'IN:' <|> ;
LAZY: 'expression' ( -- parser ) LAZY: 'expression' ( -- parser )
'comment' 'comment'
'parsing-word' sp <|> 'parsing-word' sp <|>
'quotation' sp <|> 'quotation' sp <|>
'define' sp <|> 'define' sp <|>
'array' sp <|> 'array' sp <|>
'hashtable' sp <|> 'hashtable' sp <|>
'word' sp <|> 'word' sp <|>
'atom' sp <|> 'atom' sp <|>
<*> [ <ast-expression> ] <@ ; <*> [ <ast-expression> ] <@ ;
LAZY: 'statement' ( -- parser ) LAZY: 'statement' ( -- parser )
@ -163,41 +163,41 @@ LAZY: 'statement' ( -- parser )
GENERIC: (compile) ( ast -- ) GENERIC: (compile) ( ast -- )
GENERIC: (literal) ( ast -- ) GENERIC: (literal) ( ast -- )
M: ast-number (literal) M: ast-number (literal)
ast-number-value number>string , ; ast-number-value number>string , ;
M: ast-number (compile) M: ast-number (compile)
"factor.push_data(" ,
(literal)
"," , ;
M: ast-string (literal)
"\"" ,
ast-string-value ,
"\"" , ;
M: ast-string (compile)
"factor.push_data(" , "factor.push_data(" ,
(literal) (literal)
"," , ; "," , ;
M: ast-identifier (literal) M: ast-string (literal)
"\"" ,
ast-string-value ,
"\"" , ;
M: ast-string (compile)
"factor.push_data(" ,
(literal)
"," , ;
M: ast-identifier (literal)
dup ast-identifier-vocab [ dup ast-identifier-vocab [
"factor.get_word(\"" , "factor.get_word(\"" ,
dup ast-identifier-vocab , dup ast-identifier-vocab ,
"\",\"" , "\",\"" ,
ast-identifier-value , ast-identifier-value ,
"\")" , "\")" ,
] [ ] [
"factor.find_word(\"" , ast-identifier-value , "\")" , "factor.find_word(\"" , ast-identifier-value , "\")" ,
] if ; ] if ;
M: ast-identifier (compile) M: ast-identifier (compile)
(literal) ".execute(" , ; (literal) ".execute(" , ;
M: ast-define (compile) M: ast-define (compile)
"factor.define_word(\"" , "factor.define_word(\"" ,
dup ast-define-name , dup ast-define-name ,
"\",\"source\"," , "\",\"source\"," ,
ast-define-expression (compile) ast-define-expression (compile)
"," , ; "," , ;
@ -207,7 +207,7 @@ M: ast-define (compile)
unclip unclip
dup ast-comment? not [ dup ast-comment? not [
"function() {" , "function() {" ,
(compile) (compile)
do-expressions do-expressions
")}" , ")}" ,
] [ ] [
@ -217,74 +217,74 @@ M: ast-define (compile)
drop "factor.cont.next" , drop "factor.cont.next" ,
] if ; ] if ;
M: ast-quotation (literal) M: ast-quotation (literal)
"factor.make_quotation(\"source\"," , "factor.make_quotation(\"source\"," ,
ast-quotation-values do-expressions ast-quotation-values do-expressions
")" , ; ")" , ;
M: ast-quotation (compile) M: ast-quotation (compile)
"factor.push_data(factor.make_quotation(\"source\"," , "factor.push_data(factor.make_quotation(\"source\"," ,
ast-quotation-values do-expressions ast-quotation-values do-expressions
")," , ; ")," , ;
M: ast-array (literal) M: ast-array (literal)
"[" , "[" ,
ast-array-elements [ "," , ] [ (literal) ] interleave ast-array-elements [ "," , ] [ (literal) ] interleave
"]" , ; "]" , ;
M: ast-array (compile) M: ast-array (compile)
"factor.push_data(" , (literal) "," , ; "factor.push_data(" , (literal) "," , ;
M: ast-hashtable (literal) M: ast-hashtable (literal)
"new Hashtable().fromAlist([" , "new Hashtable().fromAlist([" ,
ast-hashtable-elements [ "," , ] [ (literal) ] interleave ast-hashtable-elements [ "," , ] [ (literal) ] interleave
"])" , ; "])" , ;
M: ast-hashtable (compile) M: ast-hashtable (compile)
"factor.push_data(" , (literal) "," , ; "factor.push_data(" , (literal) "," , ;
M: ast-expression (literal) M: ast-expression (literal)
ast-expression-values [ ast-expression-values [
(literal) (literal)
] each ; ] each ;
M: ast-expression (compile) M: ast-expression (compile)
ast-expression-values do-expressions ; ast-expression-values do-expressions ;
M: ast-word (literal) M: ast-word (literal)
dup ast-word-vocab [ dup ast-word-vocab [
"factor.get_word(\"" , "factor.get_word(\"" ,
dup ast-word-vocab , dup ast-word-vocab ,
"\",\"" , "\",\"" ,
ast-word-value , ast-word-value ,
"\")" , "\")" ,
] [ ] [
"factor.find_word(\"" , ast-word-value , "\")" , "factor.find_word(\"" , ast-word-value , "\")" ,
] if ; ] if ;
M: ast-word (compile) M: ast-word (compile)
"factor.push_data(" , "factor.push_data(" ,
(literal) (literal)
"," , ; "," , ;
M: ast-comment (compile) M: ast-comment (compile)
drop ; drop ;
M: ast-stack-effect (compile) M: ast-stack-effect (compile)
drop ; drop ;
M: ast-use (compile) M: ast-use (compile)
"factor.use(\"" , "factor.use(\"" ,
ast-use-name , ast-use-name ,
"\"," , ; "\"," , ;
M: ast-in (compile) M: ast-in (compile)
"factor.set_in(\"" , "factor.set_in(\"" ,
ast-in-name , ast-in-name ,
"\"," , ; "\"," , ;
M: ast-using (compile) M: ast-using (compile)
"factor.using([" , "factor.using([" ,
ast-using-names [ ast-using-names [
"," , "," ,
@ -308,17 +308,17 @@ M: string (parse-factor-quotation) ( object -- ast )
<ast-string> ; <ast-string> ;
M: quotation (parse-factor-quotation) ( object -- ast ) M: quotation (parse-factor-quotation) ( object -- ast )
[ [
[ (parse-factor-quotation) , ] each [ (parse-factor-quotation) , ] each
] { } make <ast-quotation> ; ] { } make <ast-quotation> ;
M: array (parse-factor-quotation) ( object -- ast ) M: array (parse-factor-quotation) ( object -- ast )
[ [
[ (parse-factor-quotation) , ] each [ (parse-factor-quotation) , ] each
] { } make <ast-array> ; ] { } make <ast-array> ;
M: hashtable (parse-factor-quotation) ( object -- ast ) M: hashtable (parse-factor-quotation) ( object -- ast )
>alist [ >alist [
[ (parse-factor-quotation) , ] each [ (parse-factor-quotation) , ] each
] { } make <ast-hashtable> ; ] { } make <ast-hashtable> ;
@ -328,33 +328,33 @@ M: wrapper (parse-factor-quotation) ( object -- ast )
GENERIC: fjsc-parse ( object -- ast ) GENERIC: fjsc-parse ( object -- ast )
M: string fjsc-parse ( object -- ast ) M: string fjsc-parse ( object -- ast )
'expression' parse car parse-result-parsed ; 'expression' parse-1 ;
M: quotation fjsc-parse ( object -- ast ) M: quotation fjsc-parse ( object -- ast )
[ [
[ (parse-factor-quotation) , ] each [ (parse-factor-quotation) , ] each
] { } make <ast-expression> ; ] { } make <ast-expression> ;
: fjsc-compile ( ast -- string ) : fjsc-compile ( ast -- string )
[ [
[ [
"(" , "(" ,
(compile) (compile)
")" , ")" ,
] { } make [ write ] each ] { } make [ write ] each
] string-out ; ] string-out ;
: fjsc-compile* ( string -- string ) : fjsc-compile* ( string -- string )
'statement' parse car parse-result-parsed fjsc-compile ; 'statement' parse-1 fjsc-compile ;
: fc* ( string -- string ) : fc* ( string -- string )
[ [
'statement' parse car parse-result-parsed ast-expression-values do-expressions 'statement' parse-1 ast-expression-values do-expressions
] { } make [ write ] each ; ] { } make [ write ] each ;
: fjsc-literal ( ast -- string ) : fjsc-literal ( ast -- string )
[ [
[ (literal) ] { } make [ write ] each [ (literal) ] { } make [ write ] each
] string-out ; ] string-out ;

View File

@ -0,0 +1,33 @@
IN: temporary
USING: io.unix.launcher tools.test ;
[ "" tokenize-command ] unit-test-fails
[ " " tokenize-command ] unit-test-fails
[ { "a" } ] [ "a" tokenize-command ] unit-test
[ { "abc" } ] [ "abc" tokenize-command ] unit-test
[ { "abc" } ] [ "abc " tokenize-command ] unit-test
[ { "abc" } ] [ " abc" tokenize-command ] unit-test
[ { "abc" "def" } ] [ "abc def" tokenize-command ] unit-test
[ { "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test
[ { "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test
[ { "abc\\ def" } ] [ "'abc\\\\ def'" tokenize-command ] unit-test
[ { "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test
[ { "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test
[ { "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test
[ "'abc def' \"hey" tokenize-command ] unit-test-fails
[ "'abc def" tokenize-command ] unit-test-fails
[ { "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test
[
{
"Hello world.app/Contents/MacOS/hello-ui"
"-i=boot.macosx-ppc.image"
"-include= math compiler ui"
"-deploy-vocab=hello-ui"
"-output-image=Hello world.app/Contents/Resources/hello-ui.image"
"-no-stack-traces"
"-no-user-init"
}
] [
"\"Hello world.app/Contents/MacOS/hello-ui\" -i=boot.macosx-ppc.image \"-include= math compiler ui\" -deploy-vocab=hello-ui \"-output-image=Hello world.app/Contents/Resources/hello-ui.image\" -no-stack-traces -no-user-init" tokenize-command
] unit-test

38
extra/io/unix/launcher/launcher.factor Normal file → Executable file
View File

@ -2,17 +2,45 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io io.launcher io.unix.backend io.nonblocking USING: io io.launcher io.unix.backend io.nonblocking
sequences kernel namespaces math system alien.c-types sequences kernel namespaces math system alien.c-types
debugger continuations arrays assocs combinators unix.process ; debugger continuations arrays assocs combinators unix.process
parser-combinators memoize promises strings ;
IN: io.unix.launcher IN: io.unix.launcher
! Search unix first ! Search unix first
USE: unix USE: unix
: get-arguments ( -- seq ) ! Our command line parser. Supported syntax:
+command+ get ! foo bar baz -- simple tokens
[ "/bin/sh" "-c" rot 3array ] [ +arguments+ get ] if* ; ! foo\ bar -- escaping the space
! 'foo bar' -- quotation
! "foo bar" -- quotation
LAZY: 'escaped-char' "\\" token any-char-parser &> ;
: assoc>env ( assoc -- env ) [ "=" swap 3append ] { } assoc>map ; LAZY: 'quoted-char' ( delimiter -- parser' )
'escaped-char'
swap [ member? not ] curry satisfy
<|> ; inline
LAZY: 'quoted' ( delimiter -- parser )
dup 'quoted-char' <!*> swap dup surrounded-by ;
LAZY: 'unquoted' ( -- parser ) " '\"" 'quoted-char' <!+> ;
LAZY: 'argument' ( -- parser )
"\"" 'quoted' "'" 'quoted' 'unquoted' <|> <|>
[ >string ] <@ ;
MEMO: 'arguments' ( -- parser )
'argument' " " token <!+> nonempty-list-of ;
: tokenize-command ( command -- arguments )
'arguments' just parse-1 ;
: get-arguments ( -- seq )
+command+ get [ tokenize-command ] [ +arguments+ get ] if* ;
: assoc>env ( assoc -- env )
[ "=" swap 3append ] { } assoc>map ;
: (spawn-process) ( -- ) : (spawn-process) ( -- )
[ [

View File

@ -13,7 +13,7 @@ IN: io.unix.mmap
M: unix-io <mapped-file> ( path length -- obj ) M: unix-io <mapped-file> ( path length -- obj )
swap >r swap >r
dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor
r> mmap-open \ mapped-file construct-boa ; r> mmap-open f mapped-file construct-boa ;
M: unix-io (close-mapped-file) ( mmap -- ) M: unix-io (close-mapped-file) ( mmap -- )
[ mapped-file-address ] keep [ mapped-file-address ] keep

View File

@ -53,8 +53,11 @@ TUPLE: CreateProcess-args
CreateProcess-args-lpProcessInformation CreateProcess-args-lpProcessInformation
} get-slots CreateProcess win32-error=0/f ; } get-slots CreateProcess win32-error=0/f ;
: escape-argument ( str -- newstr )
[ [ dup CHAR: " = [ CHAR: \\ , ] when , ] each ] "" make ;
: join-arguments ( args -- cmd-line ) : join-arguments ( args -- cmd-line )
[ "\"" swap "\"" 3append ] map " " join ; [ "\"" swap escape-argument "\"" 3append ] map " " join ;
: app-name/cmd-line ( -- app-name cmd-line ) : app-name/cmd-line ( -- app-name cmd-line )
+command+ get [ +command+ get [

View File

@ -109,12 +109,14 @@ M: windows-io <file-appender> ( path -- stream )
open-append <win32-file> <writer> ; open-append <win32-file> <writer> ;
M: windows-io rename-file ( from to -- ) M: windows-io rename-file ( from to -- )
[ normalize-pathname ] 2apply [ normalize-pathname ] 2apply MoveFile win32-error=0/f ;
MoveFile win32-error=0/f ;
M: windows-io delete-file ( path -- ) M: windows-io delete-file ( path -- )
normalize-pathname normalize-pathname DeleteFile win32-error=0/f ;
DeleteFile win32-error=0/f ;
M: windows-io copy-file ( from to -- )
dup parent-directory make-directories
[ normalize-pathname ] 2apply 0 CopyFile win32-error=0/f ;
M: windows-io make-directory ( path -- ) M: windows-io make-directory ( path -- )
normalize-pathname normalize-pathname

View File

@ -12,4 +12,4 @@ IN: temporary
[ 3 ] [ <straight-tunnel> T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward segment-number ] unit-test [ 3 ] [ <straight-tunnel> T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward segment-number ] unit-test
[ { 0 0 0 } ] [ <straight-tunnel> T{ oint f { 0 0 -0.25 } } over first nearest-segment oint-location ] unit-test [ F{ 0 0 0 } ] [ <straight-tunnel> T{ oint f { 0 0 -0.25 } } over first nearest-segment oint-location ] unit-test

View File

@ -13,7 +13,7 @@ SYMBOL: def-hash-keys
2dup at -rot >r >r ?push r> r> set-at ; 2dup at -rot >r >r ?push r> r> set-at ;
: add-word-def ( word quot -- ) : add-word-def ( word quot -- )
dup quotation? [ dup callable? [
def-hash get-global set-hash-vector def-hash get-global set-hash-vector
] [ ] [
2drop 2drop
@ -33,6 +33,7 @@ SYMBOL: def-hash-keys
{ [ drop drop drop ] 3drop } { [ drop drop drop ] 3drop }
{ [ 0 = ] zero? } { [ 0 = ] zero? }
{ [ pop drop ] pop* } { [ pop drop ] pop* }
{ [ [ ] if ] when }
} [ first2 swap add-word-def ] each ; } [ first2 swap add-word-def ] each ;
: accessor-words ( -- seq ) : accessor-words ( -- seq )
@ -108,13 +109,13 @@ M: object lint ( obj -- seq )
: subseq/member? ( subseq/member seq -- ? ) : subseq/member? ( subseq/member seq -- ? )
{ [ 2dup start ] [ 2dup member? ] } || 2nip ; { [ 2dup start ] [ 2dup member? ] } || 2nip ;
M: quotation lint ( quot -- seq ) M: callable lint ( quot -- seq )
def-hash-keys get [ def-hash-keys get [
swap subseq/member? swap subseq/member?
] curry* subset ; ] curry* subset ;
M: word lint ( word -- seq ) M: word lint ( word -- seq )
word-def dup quotation? [ lint ] [ drop f ] if ; word-def dup callable? [ lint ] [ drop f ] if ;
: word-path. ( word -- ) : word-path. ( word -- )
[ word-vocabulary ":" ] keep unparse 3append write nl ; [ word-vocabulary ":" ] keep unparse 3append write nl ;

View File

@ -24,7 +24,7 @@ M: integer b, ( m n -- ) >endian % ;
! for doing native, platform-dependent sized values ! for doing native, platform-dependent sized values
M: string b, ( n string -- ) heap-size b, ; M: string b, ( n string -- ) heap-size b, ;
: read-native ( string -- ) heap-size read endian> ; : read-native ( string -- n ) heap-size read endian> ;
! Portable ! Portable
: s8, ( n -- ) 1 b, ; : s8, ( n -- ) 1 b, ;

17
extra/parser-combinators/parser-combinators-docs.factor Normal file → Executable file
View File

@ -3,14 +3,23 @@
USING: help.markup help.syntax parser-combinators ; USING: help.markup help.syntax parser-combinators ;
HELP: list-of HELP: list-of
{ $values { $values
{ "items" "a parser object" } { "separator" "a parser object" } { "parser" "a parser object" } } { "items" "a parser object" } { "separator" "a parser object" } { "parser" "a parser object" } }
{ $description { $description
"Return a parser for parsing the repetition of things that are " "Return a parser for parsing the repetition of things that are "
"separated by a certain symbol. For example, comma separated lists. " "separated by a certain symbol. For example, comma separated lists. "
"'items' is a parser that can parse the individual elements. 'separator' " "'items' is a parser that can parse the individual elements. 'separator' "
"is a parser for the symbol that separatest them. The result tree of " "is a parser for the symbol that separatest them. The result tree of "
"the resulting parser is an array of the parsed elements." } "the resulting parser is an array of the parsed elements." }
{ $example "USE: parser-combinators" "\"1,2,3,4\" 'integer' \",\" token list-of parse car parse-result-parsed ." "{ 1 2 3 4 }" } { $example "USE: parser-combinators" "\"1,2,3,4\" 'integer' \",\" token list-of parse-1 ." "{ 1 2 3 4 }" }
{ $see-also list-of } ; { $see-also list-of } ;
HELP: any-char-parser
{ $values
{ "parser" "a parser object" } }
{ $description
"Return a parser that consumes a single value "
"from the input string. The value consumed is the "
"result of the parse." }
{ $examples
{ $example "USING: lazy-lists parser-combinators ;" "\"foo\" any-char-parser parse-1 ." "102" } } ;

50
extra/parser-combinators/parser-combinators.factor Normal file → Executable file
View File

@ -15,6 +15,9 @@ M: promise (parse) ( input parser -- list )
TUPLE: parse-result parsed unparsed ; TUPLE: parse-result parsed unparsed ;
: parse-1 ( input parser -- result )
parse car parse-result-parsed ;
C: <parse-result> parse-result C: <parse-result> parse-result
TUPLE: token-parser string ; TUPLE: token-parser string ;
@ -23,7 +26,7 @@ C: token token-parser ( string -- parser )
M: token-parser (parse) ( input parser -- list ) M: token-parser (parse) ( input parser -- list )
token-parser-string swap over ?head-slice [ token-parser-string swap over ?head-slice [
<parse-result> 1list <parse-result> 1list
] [ ] [
2drop nil 2drop nil
] if ; ] if ;
@ -43,9 +46,12 @@ M: satisfy-parser (parse) ( input parser -- list )
swap <parse-result> 1list swap <parse-result> 1list
] [ ] [
2drop nil 2drop nil
] if ] if
] if ; ] if ;
LAZY: any-char-parser ( -- parser )
[ drop t ] satisfy ;
TUPLE: epsilon-parser ; TUPLE: epsilon-parser ;
C: epsilon epsilon-parser ( -- parser ) C: epsilon epsilon-parser ( -- parser )
@ -63,7 +69,7 @@ C: succeed succeed-parser ( result -- parser )
M: succeed-parser (parse) ( input parser -- list ) M: succeed-parser (parse) ( input parser -- list )
#! A parser that always returns 'result' as a #! A parser that always returns 'result' as a
#! successful parse with no input consumed. #! successful parse with no input consumed.
succeed-parser-result swap <parse-result> 1list ; succeed-parser-result swap <parse-result> 1list ;
TUPLE: fail-parser ; TUPLE: fail-parser ;
@ -81,7 +87,7 @@ TUPLE: and-parser parsers ;
over and-parser? [ over and-parser? [
>r and-parser-parsers r> add >r and-parser-parsers r> add
] [ ] [
2array 2array
] if \ and-parser construct-boa ; ] if \ and-parser construct-boa ;
: and-parser-parse ( list p1 -- list ) : and-parser-parse ( list p1 -- list )
@ -92,13 +98,13 @@ TUPLE: and-parser parsers ;
[ parse-result-parsed 2array ] keep [ parse-result-parsed 2array ] keep
parse-result-unparsed <parse-result> parse-result-unparsed <parse-result>
] lmap-with ] lmap-with
] lmap-with lconcat ; ] lmap-with lconcat ;
M: and-parser (parse) ( input parser -- list ) M: and-parser (parse) ( input parser -- list )
#! Parse 'input' by sequentially combining the #! Parse 'input' by sequentially combining the
#! two parsers. First parser1 is applied to the #! two parsers. First parser1 is applied to the
#! input then parser2 is applied to the rest of #! input then parser2 is applied to the rest of
#! the input strings from the first parser. #! the input strings from the first parser.
and-parser-parsers unclip swapd parse [ [ and-parser-parse ] reduce ] 2curry promise ; and-parser-parsers unclip swapd parse [ [ and-parser-parse ] reduce ] 2curry promise ;
TUPLE: or-parser p1 p2 ; TUPLE: or-parser p1 p2 ;
@ -115,7 +121,7 @@ M: or-parser (parse) ( input parser1 -- list )
#! Return a new string without any leading whitespace #! Return a new string without any leading whitespace
#! from the original string. #! from the original string.
dup empty? [ dup empty? [
dup first blank? [ 1 tail-slice left-trim-slice ] when dup first blank? [ 1 tail-slice left-trim-slice ] when
] unless ; ] unless ;
TUPLE: sp-parser p1 ; TUPLE: sp-parser p1 ;
@ -136,7 +142,7 @@ C: just just-parser ( p1 -- parser )
M: just-parser (parse) ( input parser -- result ) M: just-parser (parse) ( input parser -- result )
#! Calls the given parser on the input removes #! Calls the given parser on the input removes
#! from the results anything where the remaining #! from the results anything where the remaining
#! input to be parsed is not empty. So ensures a #! input to be parsed is not empty. So ensures a
#! fully parsed input string. #! fully parsed input string.
just-parser-p1 parse [ parse-result-unparsed empty? ] lsubset ; just-parser-p1 parse [ parse-result-unparsed empty? ] lsubset ;
@ -150,8 +156,8 @@ M: apply-parser (parse) ( input parser -- result )
#! The result of that quotation then becomes the new parse result. #! The result of that quotation then becomes the new parse result.
#! This allows modification of parse tree results (like #! This allows modification of parse tree results (like
#! converting strings to integers, etc). #! converting strings to integers, etc).
[ apply-parser-p1 ] keep apply-parser-quot [ apply-parser-p1 ] keep apply-parser-quot
-rot parse [ -rot parse [
[ parse-result-parsed swap call ] keep [ parse-result-parsed swap call ] keep
parse-result-unparsed <parse-result> parse-result-unparsed <parse-result>
] lmap-with ; ] lmap-with ;
@ -165,7 +171,7 @@ M: some-parser (parse) ( input parser -- result )
#! the parse is complete (the remaining input is empty), #! the parse is complete (the remaining input is empty),
#! picks the first solution and only returns the parse #! picks the first solution and only returns the parse
#! tree since the remaining input is empty. #! tree since the remaining input is empty.
some-parser-p1 just parse car parse-result-parsed ; some-parser-p1 just parse-1 ;
: <& ( parser1 parser2 -- parser ) : <& ( parser1 parser2 -- parser )
@ -230,25 +236,31 @@ LAZY: <!?> ( parser -- parser )
#! required. #! required.
<?> only-first ; <?> only-first ;
LAZY: <(*)> ( parser -- parser ) LAZY: <(*)> ( parser -- parser )
#! Like <*> but take shortest match first. #! Like <*> but take shortest match first.
#! Implementation by Matthew Willis. #! Implementation by Matthew Willis.
{ } succeed swap dup <(*)> <&:> <|> ; { } succeed swap dup <(*)> <&:> <|> ;
LAZY: <(+)> ( parser -- parser ) LAZY: <(+)> ( parser -- parser )
#! Like <+> but take shortest match first. #! Like <+> but take shortest match first.
#! Implementation by Matthew Willis. #! Implementation by Matthew Willis.
dup <(*)> <&:> ; dup <(*)> <&:> ;
LAZY: pack ( close body open -- parser ) : pack ( close body open -- parser )
#! Parse a construct enclosed by two symbols, #! Parse a construct enclosed by two symbols,
#! given a parser for the opening symbol, the #! given a parser for the opening symbol, the
#! closing symbol, and the body. #! closing symbol, and the body.
<& &> ; <& &> ;
LAZY: list-of ( items separator -- parser ) : nonempty-list-of ( items separator -- parser )
[ over &> <*> <&:> ] keep <?> tuck pack ;
: list-of ( items separator -- parser )
#! Given a parser for the separator and for the #! Given a parser for the separator and for the
#! items themselves, return a parser that parses #! items themselves, return a parser that parses
#! lists of those items. The parse tree is an #! lists of those items. The parse tree is an
#! array of the parsed items. #! array of the parsed items.
over &> <*> <&:> { } succeed <|> ; nonempty-list-of { } succeed <|> ;
LAZY: surrounded-by ( parser start end -- parser' )
[ token ] 2apply swapd pack ;

6
extra/parser-combinators/replace/replace.factor Normal file → Executable file
View File

@ -13,21 +13,21 @@ IN: parser-combinators
} cond ; } cond ;
: search ( string parser -- seq ) : search ( string parser -- seq )
'any-char' [ drop f ] <@ <|> <*> parse dup nil? [ any-char-parser [ drop f ] <@ <|> <*> parse dup nil? [
drop { } drop { }
] [ ] [
car parse-result-parsed [ ] subset car parse-result-parsed [ ] subset
] if ; ] if ;
: search* ( string parsers -- seq ) : search* ( string parsers -- seq )
unclip [ <|> ] reduce 'any-char' [ drop f ] <@ <|> <*> parse dup nil? [ unclip [ <|> ] reduce any-char-parser [ drop f ] <@ <|> <*> parse dup nil? [
drop { } drop { }
] [ ] [
car parse-result-parsed [ ] subset car parse-result-parsed [ ] subset
] if ; ] if ;
: (replace) ( string parser -- seq ) : (replace) ( string parser -- seq )
'any-char' <|> <*> parse car parse-result-parsed ; any-char-parser <|> <*> parse-1 ;
: replace ( string parser -- result ) : replace ( string parser -- result )
[ (replace) [ tree-write ] each ] string-out ; [ (replace) [ tree-write ] each ] string-out ;

39
extra/parser-combinators/simple/simple-docs.factor Normal file → Executable file
View File

@ -3,17 +3,6 @@
USING: help.syntax help.markup parser-combinators USING: help.syntax help.markup parser-combinators
parser-combinators.simple ; parser-combinators.simple ;
HELP: 'any-char'
{ $values
{ "parser" "a parser object" } }
{ $description
"Return a parser that consumes a single value "
"from the input string. The value consumed is the "
"result of the parse." }
{ $examples
{ $example "USING: lazy-lists parser-combinators ;" "\"foo\" 'any-char' parse car parse-result-parsed ." "102" } }
{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ;
HELP: 'digit' HELP: 'digit'
{ $values { $values
{ "parser" "a parser object" } } { "parser" "a parser object" } }
@ -22,8 +11,7 @@ HELP: 'digit'
"the input string. The numeric value of the digit " "the input string. The numeric value of the digit "
" consumed is the result of the parse." } " consumed is the result of the parse." }
{ $examples { $examples
{ $example "USING: lazy-lists parser-combinators ;" "\"123\" 'digit' parse car parse-result-parsed ." "1" } } { $example "USING: lazy-lists parser-combinators ;" "\"123\" 'digit' parse-1 ." "1" } } ;
{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ;
HELP: 'integer' HELP: 'integer'
{ $values { $values
@ -33,9 +21,7 @@ HELP: 'integer'
"the input string. The numeric value of the integer " "the input string. The numeric value of the integer "
" consumed is the result of the parse." } " consumed is the result of the parse." }
{ $examples { $examples
{ $example "USING: lazy-lists parser-combinators ;" "\"123\" 'integer' parse car parse-result-parsed ." "123" } } { $example "USING: lazy-lists parser-combinators ;" "\"123\" 'integer' parse-1 ." "123" } } ;
{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ;
HELP: 'string' HELP: 'string'
{ $values { $values
{ "parser" "a parser object" } } { "parser" "a parser object" } }
@ -44,9 +30,7 @@ HELP: 'string'
"quotations from the input string. The string value " "quotations from the input string. The string value "
" consumed is the result of the parse." } " consumed is the result of the parse." }
{ $examples { $examples
{ $example "USING: lazy-lists parser-combinators ;" "\"\\\"foo\\\"\" 'string' parse car parse-result-parsed ." "\"foo\"" } } { $example "USING: lazy-lists parser-combinators ;" "\"\\\"foo\\\"\" 'string' parse-1 ." "\"foo\"" } } ;
{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ;
HELP: 'bold' HELP: 'bold'
{ $values { $values
{ "parser" "a parser object" } } { "parser" "a parser object" } }
@ -55,10 +39,8 @@ HELP: 'bold'
"the '*' character from the input string. This is " "the '*' character from the input string. This is "
"commonly used in markup languages to indicate bold " "commonly used in markup languages to indicate bold "
"faced text." } "faced text." }
{ $example "USE: parser-combinators" "\"*foo*\" 'bold' parse car parse-result-parsed ." "\"foo\"" } { $example "USE: parser-combinators" "\"*foo*\" 'bold' parse-1 ." "\"foo\"" }
{ $example "USE: parser-combinators" "\"*foo*\" 'bold' [ \"<strong>\" swap \"</strong>\" 3append ] <@ parse car parse-result-parsed ." "\"<strong>foo</strong>\"" } { $example "USE: parser-combinators" "\"*foo*\" 'bold' [ \"<strong>\" swap \"</strong>\" 3append ] <@ parse-1 ." "\"<strong>foo</strong>\"" } ;
{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ;
HELP: 'italic' HELP: 'italic'
{ $values { $values
{ "parser" "a parser object" } } { "parser" "a parser object" } }
@ -68,10 +50,8 @@ HELP: 'italic'
"commonly used in markup languages to indicate italic " "commonly used in markup languages to indicate italic "
"faced text." } "faced text." }
{ $examples { $examples
{ $example "USING: lazy-lists parser-combinators ;" "\"_foo_\" 'italic' parse car parse-result-parsed ." "\"foo\"" } { $example "USING: lazy-lists parser-combinators ;" "\"_foo_\" 'italic' parse-1 ." "\"foo\"" }
{ $example "USING: lazy-lists parser-combinators ;" "\"_foo_\" 'italic' [ \"<emphasis>\" swap \"</emphasis>\" 3append ] <@ parse car parse-result-parsed ." "\"<emphasis>foo</emphasis>\"" } } { $example "USING: lazy-lists parser-combinators ;" "\"_foo_\" 'italic' [ \"<emphasis>\" swap \"</emphasis>\" 3append ] <@ parse-1 ." "\"<emphasis>foo</emphasis>\"" } } ;
{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ;
HELP: comma-list HELP: comma-list
{ $values { $values
{ "element" "a parser object" } { "parser" "a parser object" } } { "element" "a parser object" } { "parser" "a parser object" } }
@ -80,5 +60,6 @@ HELP: comma-list
"'element' should be a parser that can parse the elements. The " "'element' should be a parser that can parse the elements. The "
"result of the parser is a sequence of the parsed elements." } "result of the parser is a sequence of the parsed elements." }
{ $examples { $examples
{ $example "USING: lazy-lists parser-combinators ;" "\"1,2,3,4\" 'integer' comma-list parse car parse-result-parsed ." "{ 1 2 3 4 }" } } { $example "USING: lazy-lits parser-combinators ;" "\"1,2,3,4\" 'integer' comma-list parse-1 ." "{ 1 2 3 4 }" } } ;
{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ;
{ $see-also 'digit' 'integer' 'string' 'bold' 'italic' comma-list } related-words

3
extra/parser-combinators/simple/simple.factor Normal file → Executable file
View File

@ -4,9 +4,6 @@ USING: kernel strings math sequences lazy-lists words
math.parser promises ; math.parser promises ;
IN: parser-combinators IN: parser-combinators
LAZY: 'any-char' ( -- parser )
[ drop t ] satisfy ;
: 'digit' ( -- parser ) : 'digit' ( -- parser )
[ digit? ] satisfy [ digit> ] <@ ; [ digit? ] satisfy [ digit> ] <@ ;

View File

@ -26,12 +26,8 @@ IN: tools.deploy
[ (copy-lines) ] [ stream-close ] [ ] cleanup ; [ (copy-lines) ] [ stream-close ] [ ] cleanup ;
: stage2 ( vm flags -- ) : stage2 ( vm flags -- )
[ >r "-i=" boot-image-name append 2array r> append dup .
"\"" % swap % "\" -i=" % <process-stream>
boot-image-name %
[ " " % % ] each
] "" make
dup print <process-stream>
dup duplex-stream-out stream-close dup duplex-stream-out stream-close
copy-lines ; copy-lines ;
@ -48,11 +44,11 @@ IN: tools.deploy
: deploy-command-line ( vm image vocab config -- vm flags ) : deploy-command-line ( vm image vocab config -- vm flags )
[ [
"\"-include=" swap profile-string "\"" 3append , "-include=" swap profile-string append ,
"-deploy-vocab=" swap append , "-deploy-vocab=" swap append ,
"\"-output-image=" swap "\"" 3append , "-output-image=" swap append ,
"-no-stack-traces" , "-no-stack-traces" ,

View File

@ -1,18 +1,17 @@
! Copyright (C) 2007 Slava Pestov. ! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io io.files io.launcher kernel namespaces sequences USING: io io.files io.launcher kernel namespaces sequences
system cocoa.plists cocoa.application tools.deploy system tools.deploy tools.deploy.config assocs hashtables
tools.deploy.config assocs hashtables prettyprint ; prettyprint io.unix.backend cocoa cocoa.plists
cocoa.application cocoa.classes qualified ;
QUALIFIED: unix
IN: tools.deploy.macosx IN: tools.deploy.macosx
: touch ( path -- ) : touch ( path -- )
"touch \"" swap "\"" 3append run-process ; { "touch" } swap add run-process ;
: rm ( path -- ) : rm ( path -- )
"rm -rf \"" swap "\"" 3append run-process ; { "rm" "-rf" } swap add run-process ;
: chmod ( path perms -- )
[ "chmod " % % " \"" % % "\"" % ] "" make run-process ;
: bundle-dir ( -- dir ) : bundle-dir ( -- dir )
vm parent-directory parent-directory ; vm parent-directory parent-directory ;
@ -21,10 +20,13 @@ IN: tools.deploy.macosx
bundle-dir over path+ -rot bundle-dir over path+ -rot
>r "Contents" path+ r> path+ copy-directory ; >r "Contents" path+ r> path+ copy-directory ;
: chmod ( path perms -- )
unix:chmod io-error ;
: copy-vm ( executable bundle-name -- vm ) : copy-vm ( executable bundle-name -- vm )
"Contents/MacOS/" path+ swap path+ vm swap "Contents/MacOS/" path+ swap path+ vm swap
[ copy-file ] keep [ copy-file ] keep
[ "755" chmod ] keep ; [ OCT: 755 chmod ] keep ;
: copy-fonts ( name -- ) : copy-fonts ( name -- )
"fonts/" resource-path "fonts/" resource-path
@ -63,6 +65,12 @@ TUPLE: macosx-deploy-implementation ;
T{ macosx-deploy-implementation } deploy-implementation set-global T{ macosx-deploy-implementation } deploy-implementation set-global
: show-in-finder ( path -- )
NSWorkspace
-> sharedWorkspace
over <NSString> rot parent-directory <NSString>
-> selectFile:inFileViewerRootedAtPath: drop ;
M: macosx-deploy-implementation deploy ( vocab -- ) M: macosx-deploy-implementation deploy ( vocab -- )
".app deploy tool" assert.app ".app deploy tool" assert.app
"." resource-path cd "." resource-path cd
@ -70,5 +78,6 @@ M: macosx-deploy-implementation deploy ( vocab -- )
bundle-name rm bundle-name rm
[ bundle-name create-app-dir ] keep [ bundle-name create-app-dir ] keep
[ bundle-name deploy.app-image ] keep [ bundle-name deploy.app-image ] keep
namespace namespace deploy*
] bind deploy* ; bundle-name show-in-finder
] bind ;

View File

@ -5,7 +5,7 @@ kernel memory namespaces cocoa.messages cocoa.runtime
cocoa.subclassing cocoa.pasteboard cocoa.types cocoa.windows cocoa.subclassing cocoa.pasteboard cocoa.types cocoa.windows
cocoa.classes cocoa.application sequences system ui ui.backend cocoa.classes cocoa.application sequences system ui ui.backend
ui.clipboards ui.gadgets ui.gadgets.worlds ui.cocoa.views ui.clipboards ui.gadgets ui.gadgets.worlds ui.cocoa.views
core-foundation ; core-foundation threads ;
IN: ui.cocoa IN: ui.cocoa
TUPLE: cocoa-ui-backend ; TUPLE: cocoa-ui-backend ;
@ -19,7 +19,7 @@ SYMBOL: stop-after-last-window?
: event-loop ( -- ) : event-loop ( -- )
event-loop? [ event-loop? [
[ [
[ NSApp do-events ui-step ] ui-try [ NSApp do-events ui-step 10 sleep ] ui-try
] with-autorelease-pool event-loop ] with-autorelease-pool event-loop
] when ; ] when ;

View File

@ -40,13 +40,13 @@ M: incremental pref-dim*
swap set-rect-loc ; swap set-rect-loc ;
: prefer-incremental ( gadget -- ) : prefer-incremental ( gadget -- )
dup forget-pref-dim dup pref-dim over set-rect-dim dup forget-pref-dim dup pref-dim swap set-rect-dim ;
layout ;
: add-incremental ( gadget incremental -- ) : add-incremental ( gadget incremental -- )
not-in-layout not-in-layout
2dup (add-gadget) 2dup (add-gadget)
over prefer-incremental over prefer-incremental
over layout-later
2dup incremental-loc 2dup incremental-loc
tuck update-cursor tuck update-cursor
dup prefer-incremental dup prefer-incremental

View File

@ -67,11 +67,11 @@ M: workspace model-changed
: com-profiler profiler-gadget select-tool ; : com-profiler profiler-gadget select-tool ;
workspace "tool-switching" f { workspace "tool-switching" f {
{ T{ key-down f f "F2" } com-listener } { T{ key-down f { C+ } "1" } com-listener }
{ T{ key-down f f "F3" } com-browser } { T{ key-down f { C+ } "2" } com-browser }
{ T{ key-down f f "F4" } com-inspector } { T{ key-down f { C+ } "3" } com-inspector }
{ T{ key-down f f "F5" } com-walker } { T{ key-down f { C+ } "4" } com-walker }
{ T{ key-down f f "F6" } com-profiler } { T{ key-down f { C+ } "5" } com-profiler }
} define-command-map } define-command-map
\ workspace-window \ workspace-window
@ -86,8 +86,8 @@ H{ { +nullary+ t } { +listener+ t } } define-command
workspace "workflow" f { workspace "workflow" f {
{ T{ key-down f { C+ } "n" } workspace-window } { T{ key-down f { C+ } "n" } workspace-window }
{ T{ key-down f f "ESC" } hide-popup } { T{ key-down f f "ESC" } hide-popup }
{ T{ key-down f f "F8" } refresh-all } { T{ key-down f f "F2" } refresh-all }
{ T{ key-down f { A+ } "F8" } test-changes } { T{ key-down f { A+ } "F2" } test-changes }
} define-command-map } define-command-map
[ [

View File

@ -2,11 +2,10 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: classes continuations help help.topics kernel models USING: classes continuations help help.topics kernel models
sequences ui ui.backend ui.tools.debugger ui.gadgets sequences ui ui.backend ui.tools.debugger ui.gadgets
ui.gadgets.books ui.gadgets.buttons ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled
ui.gadgets.labelled ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks
ui.gadgets.tracks ui.gadgets.worlds ui.gadgets.presentations ui.gadgets.worlds ui.gadgets.presentations ui.gadgets.status-bar
ui.gadgets.status-bar ui.commands ui.gestures assocs arrays ui.commands ui.gestures assocs arrays namespaces ;
namespaces ;
IN: ui.tools.workspace IN: ui.tools.workspace
TUPLE: workspace book listener popup ; TUPLE: workspace book listener popup ;

View File

@ -4,7 +4,7 @@ USING: arrays assocs io kernel math models namespaces
prettyprint dlists sequences threads sequences words timers prettyprint dlists sequences threads sequences words timers
debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
ui.gestures ui.backend ui.render continuations init ui.gestures ui.backend ui.render continuations init
combinators ; combinators hashtables ;
IN: ui IN: ui
! Assoc mapping aliens to gadgets ! Assoc mapping aliens to gadgets
@ -65,18 +65,6 @@ M: world ungraft*
dup world-handle (close-window) dup world-handle (close-window)
reset-world ; reset-world ;
: open-world-window ( world -- )
dup pref-dim over set-gadget-dim dup relayout graft ;
: open-window ( gadget title -- )
>r [ 1 track, ] { 0 1 } make-track r>
f <world> open-world-window ;
HOOK: close-window ui-backend ( gadget -- )
M: object close-window
find-world [ ungraft ] when* ;
: find-window ( quot -- world ) : find-window ( quot -- world )
windows get values windows get values
[ gadget-child swap call ] curry* find-last nip ; inline [ gadget-child swap call ] curry* find-last nip ; inline
@ -126,7 +114,7 @@ SYMBOL: ui-hook
layout-queue [ layout-queue [
dup layout find-world [ , ] when* dup layout find-world [ , ] when*
] dlist-slurp ] dlist-slurp
] { } make ; ] { } make prune ;
: redraw-worlds ( seq -- ) : redraw-worlds ( seq -- )
[ dup update-hand draw-world ] each ; [ dup update-hand draw-world ] each ;
@ -148,9 +136,20 @@ SYMBOL: ui-hook
notify-queued notify-queued
layout-queued layout-queued
redraw-worlds redraw-worlds
10 sleep
] assert-depth ; ] assert-depth ;
: open-world-window ( world -- )
dup pref-dim over set-gadget-dim dup relayout graft ui-step ;
: open-window ( gadget title -- )
>r [ 1 track, ] { 0 1 } make-track r>
f <world> open-world-window ;
HOOK: close-window ui-backend ( gadget -- )
M: object close-window
find-world [ ungraft ] when* ;
: start-ui ( -- ) : start-ui ( -- )
init-timers init-timers
restore-windows? [ restore-windows? [

View File

@ -94,8 +94,7 @@ SYMBOL: mouse-captured
3drop window draw-world ; 3drop window draw-world ;
: handle-wm-size ( hWnd uMsg wParam lParam -- ) : handle-wm-size ( hWnd uMsg wParam lParam -- )
[ lo-word ] keep hi-word make-RECT get-RECT-dimensions 2array [ lo-word ] keep hi-word make-RECT get-RECT-dimensions 2array 2nip
2nip
dup { 0 0 } = [ 2drop ] [ swap window set-gadget-dim ui-step ] if ; dup { 0 0 } = [ 2drop ] [ swap window set-gadget-dim ui-step ] if ;
: wm-keydown-codes ( -- key ) : wm-keydown-codes ( -- key )
@ -348,7 +347,10 @@ M: windows-ui-backend (close-window)
: event-loop ( msg -- ) : event-loop ( msg -- )
{ {
{ [ windows get empty? ] [ drop ] } { [ windows get empty? ] [ drop ] }
{ [ dup peek-message? ] [ >r [ ui-step ] ui-try r> event-loop ] } { [ dup peek-message? ] [
>r [ ui-step 10 sleep ] ui-try
r> event-loop
] }
{ [ dup MSG-message WM_QUIT = ] [ drop ] } { [ dup MSG-message WM_QUIT = ] [ drop ] }
{ [ t ] [ { [ t ] [
dup TranslateMessage drop dup TranslateMessage drop
@ -381,7 +383,7 @@ M: windows-ui-backend (close-window)
>r class-name-ptr get-global f r> >r class-name-ptr get-global f r>
>r >r >r ex-style r> r> >r >r >r ex-style r> r>
WS_CLIPSIBLINGS WS_CLIPCHILDREN bitor style bitor WS_CLIPSIBLINGS WS_CLIPCHILDREN bitor style bitor
0 0 r> CW_USEDEFAULT dup r>
get-RECT-dimensions get-RECT-dimensions
f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ; f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ;

View File

@ -158,18 +158,14 @@ M: world selection-request-event
{ [ t ] [ drop send-notify-failure ] } { [ t ] [ drop send-notify-failure ] }
} cond ; } cond ;
: close-window ( handle -- ) M: x11-ui-backend (close-window) ( handle -- )
dup x11-handle-xic XDestroyIC dup x11-handle-xic XDestroyIC
dup x11-handle-glx destroy-glx dup x11-handle-glx destroy-glx
x11-handle-window dup unregister-window x11-handle-window dup unregister-window
destroy-window ; destroy-window ;
M: world client-event M: world client-event
swap close-box? [ swap close-box? [ ungraft ] [ drop ] if ;
dup world-handle >r stop-world r> close-window
] [
drop
] if ;
: gadget-window ( world -- ) : gadget-window ( world -- )
dup world-loc over rect-dim glx-window dup world-loc over rect-dim glx-window
@ -182,7 +178,7 @@ M: world client-event
next-event dup next-event dup
None XFilterEvent zero? [ drop wait-event ] unless None XFilterEvent zero? [ drop wait-event ] unless
] [ ] [
ui-step wait-event ui-step 10 sleep wait-event
] if ; ] if ;
: do-events ( -- ) : do-events ( -- )
@ -222,7 +218,7 @@ M: x11-ui-backend set-title ( string world -- )
world-handle x11-handle-window swap dpy get -rot world-handle x11-handle-window swap dpy get -rot
3dup set-title-old set-title-new ; 3dup set-title-old set-title-new ;
M: x11-ui-backend (open-world-window) ( world -- ) M: x11-ui-backend (open-window) ( world -- )
dup gadget-window dup gadget-window
world-handle x11-handle-window dup set-closable map-window ; world-handle x11-handle-window dup set-closable map-window ;

18
extra/webapps/fjsc/fjsc.factor Normal file → Executable file
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
! !
USING: kernel furnace fjsc parser-combinators namespaces USING: kernel furnace fjsc parser-combinators namespaces
lazy-lists io io.files furnace.validator sequences lazy-lists io io.files furnace.validator sequences
http.client http.server http.server.responders http.client http.server http.server.responders
webapps.file ; webapps.file ;
IN: webapps.fjsc IN: webapps.fjsc
@ -11,15 +11,15 @@ IN: webapps.fjsc
#! Compile the factor code as a string, outputting the http #! Compile the factor code as a string, outputting the http
#! response containing the javascript. #! response containing the javascript.
serving-text serving-text
'expression' parse car parse-result-parsed fjsc-compile 'expression' parse-1 fjsc-compile
write flush ; write flush ;
! The 'compile' action results in an URL that looks like ! The 'compile' action results in an URL that looks like
! 'responder/fjsc/compile'. It takes one query or post ! 'responder/fjsc/compile'. It takes one query or post
! parameter called 'code'. It calls the 'compile' word ! parameter called 'code'. It calls the 'compile' word
! passing the parameter to it on the stack. ! passing the parameter to it on the stack.
\ compile { \ compile {
{ "code" v-required } { "code" v-required }
} define-action } define-action
: compile-url ( url -- ) : compile-url ( url -- )
@ -28,18 +28,18 @@ IN: webapps.fjsc
"http://" host rot 3append http-get 2nip compile "();" write flush ; "http://" host rot 3append http-get 2nip compile "();" write flush ;
\ compile-url { \ compile-url {
{ "url" v-required } { "url" v-required }
} define-action } define-action
: repl ( -- ) : repl ( -- )
#! The main 'repl' page. #! The main 'repl' page.
f "repl" "head" render-page* ; f "repl" "head" render-page* ;
! An action called 'repl' ! An action called 'repl'
\ repl { } define-action \ repl { } define-action
: fjsc-web-app ( -- ) : fjsc-web-app ( -- )
! Create the web app, providing access ! Create the web app, providing access
! under '/responder/fjsc' which calls the ! under '/responder/fjsc' which calls the
! 'repl' action. ! 'repl' action.
"fjsc" "repl" "extra/webapps/fjsc" web-app "fjsc" "repl" "extra/webapps/fjsc" web-app

View File

@ -18,7 +18,7 @@ TUPLE: posting author title date link body ;
#! entries is an array of { author entries } pairs. #! entries is an array of { author entries } pairs.
dup [ dup [
[ fetch-feed ] [ error. drop f ] recover [ fetch-feed ] [ error. drop f ] recover
] parallel-map [ ] subset ] parallel-map
[ [ >r first r> 2array ] curry* map ] 2map concat ; [ [ >r first r> 2array ] curry* map ] 2map concat ;
: sort-entries ( entries -- entries' ) : sort-entries ( entries -- entries' )
@ -108,6 +108,7 @@ SYMBOL: cached-postings
{ "Kio M. Smallwood" { "Kio M. Smallwood"
"http://sekenre.wordpress.com/feed/atom/" "http://sekenre.wordpress.com/feed/atom/"
"http://sekenre.wordpress.com/" } "http://sekenre.wordpress.com/" }
{ "Phil Dawes" "http://www.phildawes.net/blog/category/factor/feed/atom" "http://www.phildawes.net/blog/" }
{ "Samuel Tardieu" "http://www.rfc1149.net/blog/tag/factor/feed/atom/" "http://www.rfc1149.net/blog/tag/factor/" } { "Samuel Tardieu" "http://www.rfc1149.net/blog/tag/factor/feed/atom/" "http://www.rfc1149.net/blog/tag/factor/" }
{ "Slava Pestov" "http://factor-language.blogspot.com/atom.xml" "http://factor-language.blogspot.com/" } { "Slava Pestov" "http://factor-language.blogspot.com/atom.xml" "http://factor-language.blogspot.com/" }
} default-blogroll set-global } default-blogroll set-global

View File

@ -566,7 +566,8 @@ FUNCTION: BOOL ConnectNamedPipe ( HANDLE hNamedPipe, LPOVERLAPPED lpOverlapped )
! FUNCTION: CopyFileA ! FUNCTION: CopyFileA
! FUNCTION: CopyFileExA ! FUNCTION: CopyFileExA
! FUNCTION: CopyFileExW ! FUNCTION: CopyFileExW
! FUNCTION: CopyFileW FUNCTION: BOOL CopyFileW ( LPCTSTR lpExistingFileName, LPCTSTR lpNewFileName, BOOL bFailIfExists ) ;
: CopyFile CopyFileW ; inline
! FUNCTION: CopyLZFile ! FUNCTION: CopyLZFile
! FUNCTION: CreateActCtxA ! FUNCTION: CreateActCtxA
! FUNCTION: CreateActCtxW ! FUNCTION: CreateActCtxW
@ -575,7 +576,7 @@ FUNCTION: BOOL ConnectNamedPipe ( HANDLE hNamedPipe, LPOVERLAPPED lpOverlapped )
! FUNCTION: CreateDirectoryExA ! FUNCTION: CreateDirectoryExA
! FUNCTION: CreateDirectoryExW ! FUNCTION: CreateDirectoryExW
FUNCTION: BOOL CreateDirectoryW ( LPCTSTR lpPathName, LPSECURITY_ATTRIBUTES lpSecurityAttribytes ) ; FUNCTION: BOOL CreateDirectoryW ( LPCTSTR lpPathName, LPSECURITY_ATTRIBUTES lpSecurityAttribytes ) ;
: CreateDirectory CreateDirectoryW ; : CreateDirectory CreateDirectoryW ; inline
! FUNCTION: CreateEventA ! FUNCTION: CreateEventA
! FUNCTION: CreateEventW ! FUNCTION: CreateEventW

251
misc/factor.sh Executable file
View File

@ -0,0 +1,251 @@
#!/bin/bash -e
# Programs returning != 0 will not cause script to exit
set +e
# Case insensitive string comparison
shopt -s nocaseglob
#shopt -s nocasematch
OS=
ARCH=
WORD=
NO_UI=
ensure_program_installed() {
echo -n "Checking for $1..."
result=`type -p $1`
if ! [[ -n $result ]] ; then
echo "not found!"
echo "Install $1 and try again."
exit 1
fi
echo "found!"
}
check_ret() {
RET=$?
if [[ $RET -ne 0 ]] ; then
echo $1 failed
exit 2
fi
}
check_gcc_version() {
GCC_VERSION=`gcc --version`
if [[ $GCC_VERSION == *3.3.* ]] ; then
echo "You have a known buggy version of gcc (3.3)"
echo "Install gcc 3.4 or higher and try again."
exit 3
fi
}
check_installed_programs() {
ensure_program_installed chmod
ensure_program_installed uname
ensure_program_installed git
ensure_program_installed wget
ensure_program_installed gcc
ensure_program_installed make
check_gcc_version
}
check_library_exists() {
GCC_TEST=factor-library-test.c
GCC_OUT=factor-library-test.out
echo "Checking for library $1"
echo "int main(){return 0;}" > $GCC_TEST
gcc $GCC_TEST -o $GCC_OUT -l $1
if [[ $? -ne 0 ]] ; then
echo "Warning: library $1 not found."
echo "***Factor will compile NO_UI=1"
NO_UI=1
fi
rm -f $GCC_TEST
rm -f $GCC_OUT
}
check_X11_libraries() {
check_library_exists freetype
check_library_exists GLU
check_library_exists GL
check_library_exists X11
}
check_libraries() {
case $OS in
linux) check_X11_libraries;;
esac
}
check_factor_exists() {
if [[ -d "factor" ]] ; then
echo "A directory called 'factor' already exists."
echo "Rename or delete it and try again."
exit 4
fi
}
find_os() {
uname_s=`uname -s`
case $uname_s in
CYGWIN_NT-5.2-WOW64) OS=windows-nt;;
*CYGWIN_NT*) OS=windows-nt;;
*CYGWIN*) OS=windows-nt;;
*darwin*) OS=macosx;;
*Darwin*) OS=macosx;;
*linux*) OS=linux;;
*Linux*) OS=linux;;
esac
}
find_architecture() {
uname_m=`uname -m`
case $uname_m in
i386) ARCH=x86;;
i686) ARCH=x86;;
*86) ARCH=x86;;
"Power Macintosh") ARCH=ppc;;
esac
}
write_test_program() {
echo "#include <stdio.h>" > $C_WORD.c
echo "int main(){printf(\"%d\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c
}
find_word_size() {
C_WORD=factor-word-size
write_test_program
gcc -o $C_WORD $C_WORD.c
WORD=$(./$C_WORD)
check_ret $C_WORD
rm -f $C_WORD*
}
set_factor_binary() {
case $OS in
windows-nt) FACTOR_BINARY=factor-nt;;
macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;;
*) FACTOR_BINARY=factor;;
esac
}
echo_build_info() {
echo OS=$OS
echo ARCH=$ARCH
echo WORD=$WORD
echo FACTOR_BINARY=$FACTOR_BINARY
echo MAKE_TARGET=$MAKE_TARGET
echo BOOT_IMAGE=$BOOT_IMAGE
}
set_build_info() {
if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then
echo "OS, ARCH, or WORD is empty. Please report this"
exit 5
fi
MAKE_TARGET=$OS-$ARCH-$WORD
BOOT_IMAGE=boot.$ARCH.$WORD.image
if [[ $OS == macosx && $ARCH == ppc ]] ; then
MAKE_TARGET=$OS-$ARCH
BOOT_IMAGE=boot.macosx-ppc.image
fi
}
find_build_info() {
find_os
find_architecture
find_word_size
set_factor_binary
set_build_info
echo_build_info
}
git_clone() {
echo "Downloading the git repository from factorcode.org..."
git clone git://factorcode.org/git/factor.git
check_ret git
}
git_pull_factorcode() {
git pull git://factorcode.org/git/factor.git
check_ret git
}
cd_factor() {
cd factor
check_ret cd
}
make_clean() {
make clean
check_ret make
}
make_factor() {
make NO_UI=$NO_UI $MAKE_TARGET -j5
check_ret make
}
delete_boot_images() {
echo "Deleting old images..."
rm $BOOT_IMAGE > /dev/null 2>&1
rm $BOOT_IMAGE.* > /dev/null 2>&1
}
get_boot_image() {
wget http://factorcode.org/images/latest/$BOOT_IMAGE
check_ret wget
}
maybe_download_dlls() {
if [[ $OS == windows-nt ]] ; then
wget http://factorcode.org/dlls/freetype6.dll
check_ret
wget http://factorcode.org/dlls/zlib1.dll
check_ret
chmod 777 *.dll
check_ret
fi
}
bootstrap() {
./$FACTOR_BINARY -i=$BOOT_IMAGE
}
usage() {
echo "usage: $0 install|update"
}
install() {
check_factor_exists
check_installed_programs
find_build_info
check_libraries
git_clone
cd_factor
make_factor
get_boot_image
maybe_download_dlls
bootstrap
}
update() {
check_installed_programs
find_build_info
check_libraries
git_pull_factorcode
make_clean
make_factor
delete_boot_images
get_boot_image
bootstrap
}
case "$1" in
install) install ;;
update) update ;;
*) usage ;;
esac

View File

@ -1,120 +0,0 @@
#!/bin/bash -e
# Programs returning != 0 will not cause script to exit
set +e
# Case insensitive string comparison
shopt -s nocaseglob
#shopt -s nocasematch
ensure_program_installed() {
echo -n "Checking for $1..."
result=`type -p $1`
if ! [[ -n $result ]] ; then
echo "not found!"
echo "Install $1 and try again."
exit 1
fi
echo "found!"
}
check_ret() {
RET=$?
if [[ $RET -ne 0 ]] ; then
echo $1 failed
exit 5
fi
}
ensure_program_installed uname
ensure_program_installed git
ensure_program_installed wget
ensure_program_installed gcc
ensure_program_installed make
GCC_VERSION=`gcc --version`
if [[ $GCC_VERSION == *3.3.* ]] ; then
echo "You have a known buggy version of gcc (3.3)"
echo "Install gcc 3.4 or higher and try again."
exit 1
fi
# OS
OS=
uname_s=`uname -s`
case $uname_s in
CYGWIN_NT-5.2-WOW64) OS=windows-nt;;
*CYGWIN_NT*) OS=windows-nt;;
*CYGWIN*) OS=windows-nt;;
*darwin*) OS=macosx;;
*Darwin*) OS=macosx;;
*linux*) OS=linux;;
*Linux*) OS=linux;;
esac
# Architecture
ARCH=
uname_m=`uname -m`
case $uname_m in
i386) ARCH=x86;;
i686) ARCH=x86;;
*86) ARCH=x86;;
"Power Macintosh") ARCH=ppc;;
esac
WORD=
C_WORD=factor-word-size
# Word size
echo "#include <stdio.h>" > $C_WORD.c
echo "int main() { printf(\"%d\", 8*sizeof(long)); return 0; }" >> $C_WORD.c
gcc -o $C_WORD $C_WORD.c
WORD=$(./$C_WORD)
check_ret $C_WORD
rm -f $C_WORD*
case $OS in
windows-nt) FACTOR_BINARY=factor-nt;;
macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;;
*) FACTOR_BINARY=factor;;
esac
MAKE_TARGET=$OS-$ARCH-$WORD
BOOT_IMAGE=boot.$ARCH.$WORD.image
echo OS=$OS
echo ARCH=$ARCH
echo WORD=$WORD
echo FACTOR_BINARY=$FACTOR_BINARY
echo MAKE_TARGET=$MAKE_TARGET
echo BOOT_IMAGE=$BOOT_IMAGE
if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then
echo "OS, ARCH, or WORD is empty. Please report this"
exit 4
fi
echo "Downloading the git repository from factorcode.org..."
git clone git://factorcode.org/git/factor.git
check_ret git
cd factor
check_ret cd
make $MAKE_TARGET
check_ret make
echo "Deleting old images..."
rm $BOOT_IMAGE > /dev/null 2>&1
rm $BOOT_IMAGE.* > /dev/null 2>&1
wget http://factorcode.org/images/latest/$BOOT_IMAGE
check_ret wget
if [[ $OS == windows-nt ]] ; then
wget http://factorcode.org/dlls/freetype6.dll
check_ret
wget http://factorcode.org/dlls/zlib1.dll
check_ret
fi
./$FACTOR_BINARY -i=$BOOT_IMAGE

8
vm/Config.windows.nt Normal file
View File

@ -0,0 +1,8 @@
LIBS = -lm
EXE_SUFFIX=-nt
DLL_SUFFIX=-nt
PLAF_DLL_OBJS += vm/os-windows-nt.o
PLAF_EXE_OBJS += vm/resources.o
PLAF_EXE_OBJS += vm/main-windows-nt.o
#CFLAGS += -mwindows
include vm/Config.windows

View File

@ -1,7 +1,3 @@
LIBS = -lm WINDRES=windres
EXE_SUFFIX=-nt include vm/Config.windows.nt
DLL_SUFFIX=-nt include vm/Config.x86.32
PLAF_DLL_OBJS += vm/os-windows-nt.o
PLAF_EXE_OBJS += vm/resources.o
PLAF_EXE_OBJS += vm/main-windows-nt.o
include vm/Config.x86.32 vm/Config.windows

View File

@ -0,0 +1,4 @@
CC=/k/target/bin/x86_64-pc-mingw32-gcc
include vm/Config.windows.nt
include vm/Config.x86.64
WINDRES = /k/target/bin/windres

View File

@ -213,6 +213,7 @@ void dump_objects(F_FIXNUM type)
void factorbug(void) void factorbug(void)
{ {
reset_stdio(); reset_stdio();
open_console();
printf("Starting low level debugger...\n"); printf("Starting low level debugger...\n");
printf(" Basic commands:\n"); printf(" Basic commands:\n");

View File

@ -26,6 +26,7 @@ void default_parameters(F_PARAMETERS *p)
p->secure_gc = false; p->secure_gc = false;
p->fep = false; p->fep = false;
p->console = false;
} }
/* Get things started */ /* Get things started */
@ -110,6 +111,8 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded
p.fep = true; p.fep = true;
else if(STRNCMP(argv[i],STR_FORMAT("-i="),3) == 0) else if(STRNCMP(argv[i],STR_FORMAT("-i="),3) == 0)
p.image = argv[i] + 3; p.image = argv[i] + 3;
else if(STRCMP(argv[i],STR_FORMAT("-console")) == 0)
p.console = true ;
} }
init_factor(&p); init_factor(&p);
@ -135,6 +138,9 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded
nest_stacks(); nest_stacks();
if(p.console)
open_console();
if(p.fep) if(p.fep)
factorbug(); factorbug();

View File

@ -32,6 +32,7 @@ typedef struct {
CELL code_size; CELL code_size;
bool secure_gc; bool secure_gc;
bool fep; bool fep;
bool console;
} F_PARAMETERS; } F_PARAMETERS;
void load_image(F_PARAMETERS *p); void load_image(F_PARAMETERS *p);

View File

@ -256,3 +256,5 @@ void reset_stdio(void)
fcntl(0,F_SETFL,0); fcntl(0,F_SETFL,0);
fcntl(1,F_SETFL,0); fcntl(1,F_SETFL,0);
} }
void open_console(void) { }

View File

@ -39,3 +39,4 @@ s64 current_millis(void);
void sleep_millis(CELL msec); void sleep_millis(CELL msec);
void reset_stdio(void); void reset_stdio(void);
void open_console(void);

View File

@ -46,3 +46,5 @@ void c_to_factor_toplevel(CELL quot)
{ {
c_to_factor(quot); c_to_factor(quot);
} }
void open_console(void) { }

View File

@ -24,3 +24,4 @@ char *getenv(char *name);
s64 current_millis(void); s64 current_millis(void);
void c_to_factor_toplevel(CELL quot); void c_to_factor_toplevel(CELL quot);
void open_console(void);

View File

@ -88,3 +88,17 @@ void c_to_factor_toplevel(CELL quot)
c_to_factor(quot); c_to_factor(quot);
RemoveVectoredExceptionHandler((void*)exception_handler); RemoveVectoredExceptionHandler((void*)exception_handler);
} }
void open_console(void)
{
/*
// Do this: http://www.cygwin.com/ml/cygwin/2007-11/msg00432.html
if(console_open)
return;
if(AttachConsole(ATTACH_PARENT_PROCESS) || AllocConsole())
{
console_open = true;
}
*/
}

View File

@ -18,3 +18,5 @@ typedef char F_SYMBOL;
void c_to_factor_toplevel(CELL quot); void c_to_factor_toplevel(CELL quot);
long exception_handler(PEXCEPTION_POINTERS pe); long exception_handler(PEXCEPTION_POINTERS pe);
bool console_open;
void open_console(void);