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

Merge git://factorcode.org/git/factor

release
Daniel Ehrenberg 2007-11-27 11:14:55 -05:00
parent eca98a3b8f 9d5e67e443
commit e561e0fffd
108 changed files with 3559 additions and 696 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
Makefile
View File

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

5
core/alien/compiler/compiler.factor
View File

@ -5,8 +5,7 @@ hashtables kernel math namespaces sequences words
inference.backend inference.dataflow system
math.parser classes alien.arrays alien.c-types alien.structs
alien.syntax cpu.architecture alien inspector quotations assocs
kernel.private threads continuations.private libc combinators
init ;
kernel.private threads continuations.private libc combinators ;
IN: alien.compiler
! Common protocol for alien-invoke/alien-callback/alien-indirect
@ -302,7 +301,7 @@ M: alien-indirect generate-node
! this hashtable, they will all be blown away by code GC, beware
SYMBOL: callbacks
[ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook
callbacks global [ H{ } assoc-like ] change-at
: register-callback ( word -- ) dup callbacks get set-at ;

11
core/cpu/arm/intrinsics/intrinsics.factor
View File

@ -418,17 +418,6 @@ IN: cpu.arm.intrinsics
{ +output+ { "out" } }
} define-intrinsic
\ curry [
\ curry 3 cells %allot
"obj" operand 1 %set-slot
"quot" operand 2 %set-slot
"out" get object %store-tagged
] H{
{ +input+ { { f "obj" } { f "quot" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
! Alien intrinsics
: %alien-accessor ( quot -- )
"offset" operand dup %untag-fixnum

12
core/cpu/ppc/intrinsics/intrinsics.factor
View File

@ -580,18 +580,6 @@ IN: cpu.ppc.intrinsics
{ +output+ { "vector" } }
} define-intrinsic
\ curry [
\ curry 3 cells %allot
"obj" operand 11 1 cells STW
"quot" operand 11 2 cells STW
! Store tagged ptr in reg
"curry" get object %store-tagged
] H{
{ +input+ { { f "obj" } { f "quot" } } }
{ +scratch+ { { f "curry" } } }
{ +output+ { "curry" } }
} define-intrinsic
! Alien intrinsics
: %alien-accessor ( quot -- )
"offset" operand dup %untag-fixnum

13
core/cpu/x86/intrinsics/intrinsics.factor
View File

@ -485,19 +485,6 @@ IN: cpu.x86.intrinsics
{ +output+ { "vector" } }
} define-intrinsic
\ curry [
\ curry 3 cells [
1 object@ "obj" operand MOV
2 object@ "quot" operand MOV
! Store tagged ptr in reg
"curry" get object %store-tagged
] %allot
] H{
{ +input+ { { f "obj" } { f "quot" } } }
{ +scratch+ { { f "curry" } } }
{ +output+ { "curry" } }
} define-intrinsic
! Alien intrinsics
: %alien-accessor ( quot -- )
"offset" operand %untag-fixnum

4
core/io/files/files.factor
View File

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

2
core/quotations/quotations-docs.factor Normal file → Executable file
View File

@ -22,7 +22,7 @@ $nl
ABOUT: "quotations"
HELP: callable
{ $class-description "The class whose instances can be passed to " { $link call } ". This includes quotations, " { $link f } " (which behaves like an empty quotation), and composed quotations built up with " { $link curry } "." } ;
{ $class-description "The class whose instances can be passed to " { $link call } ". This includes quotations and composed quotations built up with " { $link curry } " or " { $link compose } "." } ;
HELP: quotation
{ $description "The class of quotations. See " { $link "syntax-quots" } " for syntax and " { $link "quotations" } " for general information." } ;

6
core/quotations/quotations-tests.factor
View File

@ -1,8 +1,8 @@
USING: math kernel quotations tools.test sequences ;
IN: temporary
[ [ 3 ] ] [ 3 f curry ] unit-test
[ [ \ + ] ] [ \ + f curry ] unit-test
[ [ 3 ] ] [ 3 [ ] curry ] unit-test
[ [ \ + ] ] [ \ + [ ] curry ] unit-test
[ [ \ + = ] ] [ \ + [ = ] curry ] unit-test
[ [ 1 + 2 + 3 + ] ] [
@ -14,3 +14,5 @@ IN: temporary
[ [ 3 1 2 ] ] [ [ 1 2 ] 3 add* ] unit-test
[ [ "hi" ] ] [ "hi" 1quotation ] unit-test
[ 1 \ + curry ] unit-test-fails

16
extra/bake/bake.factor
View File

@ -1,6 +1,6 @@
USING: kernel parser namespaces quotations vectors strings
sequences assocs tuples math combinators ;
USING: kernel parser namespaces quotations arrays vectors strings
sequences assocs tuples math combinators ;
IN: bake
@ -22,6 +22,10 @@ C: <splice-quot> splice-quot
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: ,u ( seq -- seq ) unclip building get push ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: exemplar
: reset-building ( -- ) 1024 <vector> building set ;
@ -35,6 +39,7 @@ DEFER: bake
: bake-item ( item -- )
{ { [ dup \ , = ] [ drop , ] }
{ [ dup \ % = ] [ drop % ] }
{ [ dup \ ,u = ] [ drop ,u ] }
{ [ dup insert-quot? ] [ insert-quot-expr call , ] }
{ [ dup splice-quot? ] [ splice-quot-expr call % ] }
{ [ dup integer? ] [ , ] }
@ -48,4 +53,9 @@ DEFER: bake
: bake-items ( seq -- ) [ bake-item ] each ;
: bake ( seq -- seq )
[ reset-building save-exemplar bake-items finish-baking ] with-scope ;
[ reset-building save-exemplar bake-items finish-baking ] with-scope ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: `{ \ } [ >array ] parse-literal \ bake parsed ; parsing

1
extra/benchmark/knucleotide/authors.txt Normal file
View File

@ -0,0 +1 @@
Eric Mertens

1671
extra/benchmark/knucleotide/knucleotide-input.txt Normal file
View File

File diff suppressed because it is too large Load Diff

64
extra/benchmark/knucleotide/knucleotide.factor Normal file
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

2
extra/benchmark/knucleotide/summary.txt Normal file
View File

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

2
extra/benchmark/mandel/mandel.factor
View File

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

2
extra/benchmark/spectral-norm/spectral-norm.factor
View File

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

2
extra/benchmark/sum-file/sum-file.factor
View File

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

3
extra/cocoa/cocoa.factor
View File

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

9
extra/cocoa/messages/messages.factor
View File

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

6
extra/documents/documents.factor Normal file → Executable file
View File

@ -167,6 +167,12 @@ M: char-elt prev-elt
M: char-elt next-elt
drop [ drop 1 +col ] (next-char) ;
TUPLE: one-char-elt ;
M: one-char-elt prev-elt 2drop ;
M: one-char-elt next-elt 2drop ;
: (word-elt) ( loc document quot -- loc )
pick >r
>r >r first2 swap r> doc-line r> call

29
extra/editors/editors.factor
View File

@ -1,21 +1,36 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser kernel namespaces sequences definitions io.files
inspector continuations tuples tools.crossref io prettyprint
source-files ;
inspector continuations tuples tools.crossref tools.browser
io prettyprint source-files assocs vocabs vocabs.loader ;
IN: editors
TUPLE: no-edit-hook ;
M: no-edit-hook summary drop "No edit hook is set" ;
M: no-edit-hook summary
drop "You must load one of the below vocabularies before using editor integration:" ;
SYMBOL: edit-hook
: available-editors ( -- seq )
"editors" all-child-vocabs
values concat [ vocab-name ] map ;
: editor-restarts ( -- alist )
available-editors
[ "Load " over append swap ] { } map>assoc ;
: no-edit-hook ( -- )
\ no-edit-hook construct-empty
editor-restarts throw-restarts
require ;
: edit-location ( file line -- )
>r ?resource-path r>
edit-hook get dup [
\ no-edit-hook construct-empty throw
] if ;
edit-hook get [
>r >r ?resource-path r> r> call
] [
no-edit-hook edit-location
] if* ;
: edit ( defspec -- )
where [ first2 edit-location ] when* ;

1
extra/editors/editpadpro/summary.txt Normal file
View File

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

1
extra/editors/emacs/summary.txt Normal file
View File

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

6
extra/editors/gvim/gvim.factor
View File

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

1
extra/editors/gvim/summary.txt Normal file
View File

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

1
extra/editors/notepadpp/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

13
extra/editors/notepadpp/notepadpp.factor Normal file
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

1
extra/editors/notepadpp/summary.txt Normal file
View File

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

1
extra/editors/scite/summary.txt Normal file
View File

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

1
extra/editors/textmate/summary.txt Normal file
View File

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

1
extra/editors/vim/summary.txt Normal file
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
{ 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
{ 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
{ 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
{ 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
{ 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
{ 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
{ T{ ast-stack-effect f { } { } } } [
"( -- )" 'stack-effect' parse car parse-result-parsed
"( -- )" 'stack-effect' parse-1
] unit-test
{ } [
": foo ( a b -- c d ) abcdefghijklmn 123 ;" 'expression' parse car drop
] unit-test
{ T{ ast-expression f { T{ ast-string f "abcd" } } } } [
"\"abcd\"" 'statement' parse car parse-result-parsed
] unit-test
{ T{ ast-expression f { T{ ast-string f "abcd" } } } } [
"\"abcd\"" 'statement' parse-1
] unit-test
{ T{ ast-expression f { T{ ast-use f "foo" } } } } [
"USE: foo" 'statement' parse car parse-result-parsed
"USE: foo" 'statement' parse-1
] unit-test
{ T{ ast-expression f { T{ ast-in f "foo" } } } } [
"IN: foo" 'statement' parse car parse-result-parsed
"IN: foo" 'statement' parse-1
] unit-test
{ 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

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

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

33
extra/io/unix/launcher/launcher-tests.factor Executable file
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.
USING: io io.launcher io.unix.backend io.nonblocking
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
! Search unix first
USE: unix
: get-arguments ( -- seq )
+command+ get
[ "/bin/sh" "-c" rot 3array ] [ +arguments+ get ] if* ;
! Our command line parser. Supported syntax:
! foo bar baz -- simple tokens
! 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) ( -- )
[

2
extra/io/unix/mmap/mmap.factor
View File

@ -13,7 +13,7 @@ IN: io.unix.mmap
M: unix-io <mapped-file> ( path length -- obj )
swap >r
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 -- )
[ mapped-file-address ] keep

5
extra/io/windows/launcher/launcher.factor
View File

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

10
extra/io/windows/windows.factor
View File

@ -109,12 +109,14 @@ M: windows-io <file-appender> ( path -- stream )
open-append <win32-file> <writer> ;
M: windows-io rename-file ( from to -- )
[ normalize-pathname ] 2apply
MoveFile win32-error=0/f ;
[ normalize-pathname ] 2apply MoveFile win32-error=0/f ;
M: windows-io delete-file ( path -- )
normalize-pathname
DeleteFile win32-error=0/f ;
normalize-pathname 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 -- )
normalize-pathname

2
extra/jamshred/tunnel/tunnel-tests.factor
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
[ { 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

7
extra/lint/lint.factor
View File

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

2
extra/macros/macros.factor Normal file → Executable file
View File

@ -19,7 +19,7 @@ IN: macros
: MACRO:
(:) (MACRO:) ; parsing
PREDICATE: word macro
PREDICATE: compound macro
"macro" word-prop >boolean ;
M: macro definer drop \ MACRO: \ ; ;

2
extra/pack/pack.factor
View File

@ -24,7 +24,7 @@ M: integer b, ( m n -- ) >endian % ;
! for doing native, platform-dependent sized values
M: string b, ( n string -- ) heap-size b, ;
: read-native ( string -- ) heap-size read endian> ;
: read-native ( string -- n ) heap-size read endian> ;
! Portable
: 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 ;
HELP: list-of
{ $values
{ $values
{ "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 "
"separated by a certain symbol. For example, comma separated lists. "
"'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." }
{ $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 } ;
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" } } ;

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

@ -1,122 +1,130 @@
! Copyright (C) 2004 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: lazy-lists promises kernel sequences strings math io
arrays namespaces splitting ;
USING: lazy-lists promises kernel sequences strings math
arrays splitting ;
IN: parser-combinators
! Parser combinator protocol
GENERIC: (parse) ( input parser -- list )
GENERIC: parse ( input parser -- list )
M: promise (parse) ( input parser -- list )
force (parse) ;
: parse ( input parser -- promise )
(parse) ;
M: promise parse ( input parser -- list )
force parse ;
TUPLE: parse-result parsed unparsed ;
: parse-1 ( input parser -- result )
parse dup nil? [
"Parse error" throw
] [
car parse-result-parsed
] if ;
C: <parse-result> parse-result
TUPLE: token-parser string ;
C: token token-parser ( string -- parser )
M: token-parser (parse) ( input parser -- list )
token-parser-string swap over ?head-slice [
<parse-result> 1list
] [
2drop nil
] if ;
M: token-parser parse ( input parser -- list )
token-parser-string swap over ?head-slice [
<parse-result> 1list
] [
2drop nil
] if ;
TUPLE: satisfy-parser quot ;
C: satisfy satisfy-parser ( quot -- parser )
M: satisfy-parser (parse) ( input parser -- list )
#! A parser that succeeds if the predicate,
#! when passed the first character in the input, returns
#! true.
over empty? [
2drop nil
] [
satisfy-parser-quot >r unclip-slice dup r> call [
swap <parse-result> 1list
M: satisfy-parser parse ( input parser -- list )
#! A parser that succeeds if the predicate,
#! when passed the first character in the input, returns
#! true.
over empty? [
2drop nil
] [
2drop nil
] if
] if ;
satisfy-parser-quot >r unclip-slice dup r> call [
swap <parse-result> 1list
] [
2drop nil
] if
] if ;
LAZY: any-char-parser ( -- parser )
[ drop t ] satisfy ;
TUPLE: epsilon-parser ;
C: epsilon epsilon-parser ( -- parser )
M: epsilon-parser (parse) ( input parser -- list )
#! A parser that parses the empty string. It
#! does not consume any input and always returns
#! an empty list as the parse tree with the
#! unmodified input.
drop "" swap <parse-result> 1list ;
M: epsilon-parser parse ( input parser -- list )
#! A parser that parses the empty string. It
#! does not consume any input and always returns
#! an empty list as the parse tree with the
#! unmodified input.
drop "" swap <parse-result> 1list ;
TUPLE: succeed-parser result ;
C: succeed succeed-parser ( result -- parser )
M: succeed-parser (parse) ( input parser -- list )
#! A parser that always returns 'result' as a
#! successful parse with no input consumed.
succeed-parser-result swap <parse-result> 1list ;
M: succeed-parser parse ( input parser -- list )
#! A parser that always returns 'result' as a
#! successful parse with no input consumed.
succeed-parser-result swap <parse-result> 1list ;
TUPLE: fail-parser ;
C: fail fail-parser ( -- parser )
M: fail-parser (parse) ( input parser -- list )
#! A parser that always fails and returns
#! an empty list of successes.
2drop nil ;
M: fail-parser parse ( input parser -- list )
#! A parser that always fails and returns
#! an empty list of successes.
2drop nil ;
TUPLE: and-parser parsers ;
: <&> ( parser1 parser2 -- parser )
over and-parser? [
>r and-parser-parsers r> add
] [
2array
] if \ and-parser construct-boa ;
over and-parser? [
>r and-parser-parsers r> add
] [
2array
] if and-parser construct-boa ;
: and-parser-parse ( list p1 -- list )
swap [
dup parse-result-unparsed rot parse
[
>r parse-result-parsed r>
[ parse-result-parsed 2array ] keep
parse-result-unparsed <parse-result>
] lmap-with
] lmap-with lconcat ;
M: and-parser (parse) ( input parser -- list )
#! Parse 'input' by sequentially combining the
#! two parsers. First parser1 is applied to the
#! input then parser2 is applied to the rest of
#! the input strings from the first parser.
and-parser-parsers unclip swapd parse [ [ and-parser-parse ] reduce ] 2curry promise ;
swap [
dup parse-result-unparsed rot parse
[
>r parse-result-parsed r>
[ parse-result-parsed 2array ] keep
parse-result-unparsed <parse-result>
] lmap-with
] lmap-with lconcat ;
M: and-parser parse ( input parser -- list )
#! Parse 'input' by sequentially combining the
#! two parsers. First parser1 is applied to the
#! input then parser2 is applied to the rest of
#! the input strings from the first parser.
and-parser-parsers unclip swapd parse
[ [ and-parser-parse ] reduce ] 2curry promise ;
TUPLE: or-parser p1 p2 ;
C: <|> or-parser ( parser1 parser2 -- parser )
M: or-parser (parse) ( input parser1 -- list )
#! Return the combined list resulting from the parses
#! of parser1 and parser2 being applied to the same
#! input. This implements the choice parsing operator.
[ or-parser-p1 ] keep or-parser-p2 >r dupd parse swap r> parse lappend ;
M: or-parser parse ( input parser1 -- list )
#! Return the combined list resulting from the parses
#! of parser1 and parser2 being applied to the same
#! input. This implements the choice parsing operator.
[ or-parser-p1 ] keep or-parser-p2 >r dupd parse swap r> parse lappend ;
: left-trim-slice ( string -- string )
#! Return a new string without any leading whitespace
#! from the original string.
dup empty? [
dup first blank? [ 1 tail-slice left-trim-slice ] when
] unless ;
#! Return a new string without any leading whitespace
#! from the original string.
dup empty? [
dup first blank? [ 1 tail-slice left-trim-slice ] when
] unless ;
TUPLE: sp-parser p1 ;
@ -124,131 +132,141 @@ TUPLE: sp-parser p1 ;
#! calling the original parser.
C: sp sp-parser ( p1 -- parser )
M: sp-parser (parse) ( input parser -- list )
#! Skip all leading whitespace from the input then call
#! the parser on the remaining input.
>r left-trim-slice r> sp-parser-p1 parse ;
M: sp-parser parse ( input parser -- list )
#! Skip all leading whitespace from the input then call
#! the parser on the remaining input.
>r left-trim-slice r> sp-parser-p1 parse ;
TUPLE: just-parser p1 ;
C: just just-parser ( p1 -- parser )
M: just-parser (parse) ( input parser -- result )
#! Calls the given parser on the input removes
#! from the results anything where the remaining
#! input to be parsed is not empty. So ensures a
#! fully parsed input string.
just-parser-p1 parse [ parse-result-unparsed empty? ] lsubset ;
M: just-parser parse ( input parser -- result )
#! Calls the given parser on the input removes
#! from the results anything where the remaining
#! input to be parsed is not empty. So ensures a
#! fully parsed input string.
just-parser-p1 parse [ parse-result-unparsed empty? ] lsubset ;
TUPLE: apply-parser p1 quot ;
C: <@ apply-parser ( parser quot -- parser )
M: apply-parser (parse) ( input parser -- result )
#! Calls the parser on the input. For each successfull
#! parse the quot is call with the parse result on the stack.
#! The result of that quotation then becomes the new parse result.
#! This allows modification of parse tree results (like
#! converting strings to integers, etc).
[ apply-parser-p1 ] keep apply-parser-quot
-rot parse [
[ parse-result-parsed swap call ] keep
parse-result-unparsed <parse-result>
] lmap-with ;
M: apply-parser parse ( input parser -- result )
#! Calls the parser on the input. For each successfull
#! parse the quot is call with the parse result on the stack.
#! The result of that quotation then becomes the new parse result.
#! This allows modification of parse tree results (like
#! converting strings to integers, etc).
[ apply-parser-p1 ] keep apply-parser-quot
-rot parse [
[ parse-result-parsed swap call ] keep
parse-result-unparsed <parse-result>
] lmap-with ;
TUPLE: some-parser p1 ;
C: some some-parser ( p1 -- parser )
M: some-parser (parse) ( input parser -- result )
#! Calls the parser on the input, guarantees
#! the parse is complete (the remaining input is empty),
#! picks the first solution and only returns the parse
#! tree since the remaining input is empty.
some-parser-p1 just parse car parse-result-parsed ;
M: some-parser parse ( input parser -- result )
#! Calls the parser on the input, guarantees
#! the parse is complete (the remaining input is empty),
#! picks the first solution and only returns the parse
#! tree since the remaining input is empty.
some-parser-p1 just parse-1 ;
: <& ( parser1 parser2 -- parser )
#! Same as <&> except discard the results of the second parser.
<&> [ first ] <@ ;
#! Same as <&> except discard the results of the second parser.
<&> [ first ] <@ ;
: &> ( parser1 parser2 -- parser )
#! Same as <&> except discard the results of the first parser.
<&> [ second ] <@ ;
#! Same as <&> except discard the results of the first parser.
<&> [ second ] <@ ;
: <:&> ( parser1 parser2 -- result )
#! Same as <&> except flatten the result.
<&> [ dup second swap first [ % , ] { } make ] <@ ;
#! Same as <&> except flatten the result.
<&> [ first2 add ] <@ ;
: <&:> ( parser1 parser2 -- result )
#! Same as <&> except flatten the result.
<&> [ dup second swap first [ , % ] { } make ] <@ ;
#! Same as <&> except flatten the result.
<&> [ first2 swap add* ] <@ ;
: <:&:> ( parser1 parser2 -- result )
#! Same as <&> except flatten the result.
<&> [ first2 append ] <@ ;
LAZY: <*> ( parser -- parser )
dup <*> <&:> { } succeed <|> ;
dup <*> <&:> { } succeed <|> ;
: <+> ( parser -- parser )
#! Return a parser that accepts one or more occurences of the original
#! parser.
dup <*> <&:> ;
#! Return a parser that accepts one or more occurences of the original
#! parser.
dup <*> <&:> ;
LAZY: <?> ( parser -- parser )
#! Return a parser that optionally uses the parser
#! if that parser would be successfull.
[ 1array ] <@ f succeed <|> ;
#! Return a parser that optionally uses the parser
#! if that parser would be successfull.
[ 1array ] <@ f succeed <|> ;
TUPLE: only-first-parser p1 ;
LAZY: only-first ( parser -- parser )
\ only-first-parser construct-boa ;
M: only-first-parser (parse) ( input parser -- list )
#! Transform a parser into a parser that only yields
#! the first possibility.
only-first-parser-p1 parse 1 swap ltake ;
LAZY: only-first ( parser -- parser )
only-first-parser construct-boa ;
M: only-first-parser parse ( input parser -- list )
#! Transform a parser into a parser that only yields
#! the first possibility.
only-first-parser-p1 parse 1 swap ltake ;
LAZY: <!*> ( parser -- parser )
#! Like <*> but only return one possible result
#! containing all matching parses. Does not return
#! partial matches. Useful for efficiency since that's
#! usually the effect you want and cuts down on backtracking
#! required.
<*> only-first ;
#! Like <*> but only return one possible result
#! containing all matching parses. Does not return
#! partial matches. Useful for efficiency since that's
#! usually the effect you want and cuts down on backtracking
#! required.
<*> only-first ;
LAZY: <!+> ( parser -- parser )
#! Like <+> but only return one possible result
#! containing all matching parses. Does not return
#! partial matches. Useful for efficiency since that's
#! usually the effect you want and cuts down on backtracking
#! required.
<+> only-first ;
#! Like <+> but only return one possible result
#! containing all matching parses. Does not return
#! partial matches. Useful for efficiency since that's
#! usually the effect you want and cuts down on backtracking
#! required.
<+> only-first ;
LAZY: <!?> ( parser -- parser )
#! Like <?> but only return one possible result
#! containing all matching parses. Does not return
#! partial matches. Useful for efficiency since that's
#! usually the effect you want and cuts down on backtracking
#! required.
<?> only-first ;
#! Like <?> but only return one possible result
#! containing all matching parses. Does not return
#! partial matches. Useful for efficiency since that's
#! usually the effect you want and cuts down on backtracking
#! required.
<?> only-first ;
LAZY: <(*)> ( parser -- parser )
#! Like <*> but take shortest match first.
LAZY: <(*)> ( parser -- parser )
#! Like <*> but take shortest match first.
#! Implementation by Matthew Willis.
{ } succeed swap dup <(*)> <&:> <|> ;
LAZY: <(+)> ( parser -- parser )
#! Like <+> but take shortest match first.
#! Like <+> but take shortest match first.
#! Implementation by Matthew Willis.
dup <(*)> <&:> ;
LAZY: pack ( close body open -- parser )
#! Parse a construct enclosed by two symbols,
#! given a parser for the opening symbol, the
#! closing symbol, and the body.
<& &> ;
: pack ( close body open -- parser )
#! Parse a construct enclosed by two symbols,
#! given a parser for the opening symbol, the
#! closing symbol, and the body.
<& &> ;
LAZY: list-of ( items separator -- parser )
#! Given a parser for the separator and for the
#! items themselves, return a parser that parses
#! lists of those items. The parse tree is an
#! array of the parsed items.
over &> <*> <&:> { } succeed <|> ;
: nonempty-list-of ( items separator -- parser )
[ over &> <*> <&:> ] keep <?> tuck pack ;
: list-of ( items separator -- parser )
#! Given a parser for the separator and for the
#! items themselves, return a parser that parses
#! lists of those items. The parse tree is an
#! array of the parsed items.
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 ;
: search ( string parser -- seq )
'any-char' [ drop f ] <@ <|> <*> parse dup nil? [
any-char-parser [ drop f ] <@ <|> <*> parse dup nil? [
drop { }
] [
car parse-result-parsed [ ] subset
] if ;
: search* ( string parsers -- seq )
unclip [ <|> ] reduce 'any-char' [ drop f ] <@ <|> <*> parse dup nil? [
unclip [ <|> ] reduce any-char-parser [ drop f ] <@ <|> <*> parse dup nil? [
drop { }
] [
car parse-result-parsed [ ] subset
] if ;
: (replace) ( string parser -- seq )
'any-char' <|> <*> parse car parse-result-parsed ;
any-char-parser <|> <*> parse-1 ;
: replace ( string parser -- result )
[ (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
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'
{ $values
{ "parser" "a parser object" } }
@ -22,8 +11,7 @@ HELP: 'digit'
"the input string. The numeric value of the digit "
" consumed is the result of the parse." }
{ $examples
{ $example "USING: lazy-lists parser-combinators ;" "\"123\" 'digit' parse car parse-result-parsed ." "1" } }
{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ;
{ $example "USING: lazy-lists parser-combinators ;" "\"123\" 'digit' parse-1 ." "1" } } ;
HELP: 'integer'
{ $values
@ -33,9 +21,7 @@ HELP: 'integer'
"the input string. The numeric value of the integer "
" consumed is the result of the parse." }
{ $examples
{ $example "USING: lazy-lists parser-combinators ;" "\"123\" 'integer' parse car parse-result-parsed ." "123" } }
{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ;
{ $example "USING: lazy-lists parser-combinators ;" "\"123\" 'integer' parse-1 ." "123" } } ;
HELP: 'string'
{ $values
{ "parser" "a parser object" } }
@ -44,9 +30,7 @@ HELP: 'string'
"quotations from the input string. The string value "
" consumed is the result of the parse." }
{ $examples
{ $example "USING: lazy-lists parser-combinators ;" "\"\\\"foo\\\"\" 'string' parse car parse-result-parsed ." "\"foo\"" } }
{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ;
{ $example "USING: lazy-lists parser-combinators ;" "\"\\\"foo\\\"\" 'string' parse-1 ." "\"foo\"" } } ;
HELP: 'bold'
{ $values
{ "parser" "a parser object" } }
@ -55,10 +39,8 @@ HELP: 'bold'
"the '*' character from the input string. This is "
"commonly used in markup languages to indicate bold "
"faced text." }
{ $example "USE: parser-combinators" "\"*foo*\" 'bold' parse car parse-result-parsed ." "\"foo\"" }
{ $example "USE: parser-combinators" "\"*foo*\" 'bold' [ \"<strong>\" swap \"</strong>\" 3append ] <@ parse car parse-result-parsed ." "\"<strong>foo</strong>\"" }
{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ;
{ $example "USE: parser-combinators" "\"*foo*\" 'bold' parse-1 ." "\"foo\"" }
{ $example "USE: parser-combinators" "\"*foo*\" 'bold' [ \"<strong>\" swap \"</strong>\" 3append ] <@ parse-1 ." "\"<strong>foo</strong>\"" } ;
HELP: 'italic'
{ $values
{ "parser" "a parser object" } }
@ -68,10 +50,8 @@ HELP: 'italic'
"commonly used in markup languages to indicate italic "
"faced text." }
{ $examples
{ $example "USING: lazy-lists parser-combinators ;" "\"_foo_\" 'italic' parse car parse-result-parsed ." "\"foo\"" }
{ $example "USING: lazy-lists parser-combinators ;" "\"_foo_\" 'italic' [ \"<emphasis>\" swap \"</emphasis>\" 3append ] <@ parse car parse-result-parsed ." "\"<emphasis>foo</emphasis>\"" } }
{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ;
{ $example "USING: lazy-lists parser-combinators ;" "\"_foo_\" 'italic' parse-1 ." "\"foo\"" }
{ $example "USING: lazy-lists parser-combinators ;" "\"_foo_\" 'italic' [ \"<emphasis>\" swap \"</emphasis>\" 3append ] <@ parse-1 ." "\"<emphasis>foo</emphasis>\"" } } ;
HELP: comma-list
{ $values
{ "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 "
"result of the parser is a sequence of the parsed elements." }
{ $examples
{ $example "USING: lazy-lists parser-combinators ;" "\"1,2,3,4\" 'integer' comma-list parse car parse-result-parsed ." "{ 1 2 3 4 }" } }
{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ;
{ $example "USING: lazy-lits parser-combinators ;" "\"1,2,3,4\" 'integer' comma-list parse-1 ." "{ 1 2 3 4 }" } } ;
{ $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 ;
IN: parser-combinators
LAZY: 'any-char' ( -- parser )
[ drop t ] satisfy ;
: 'digit' ( -- parser )
[ digit? ] satisfy [ digit> ] <@ ;

113
extra/peg/peg-docs.factor Normal file
View File

@ -0,0 +1,113 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax peg ;
HELP: parse
{ $values
{ "string" "a string" }
{ "parse" "a parser" }
{ "result" "a <parse-result> or f" }
}
{ $description
"Given the input string, parse it using the given parser. The result is a <parse-result> object if "
"the parse was successful, otherwise it is f." } ;
HELP: token
{ $values
{ "string" "a string" }
{ "parser" "a parser" }
}
{ $description
"Returns a parser that matches the given string." } ;
HELP: range
{ $values
{ "min" "a character" }
{ "max" "a character" }
{ "parser" "a parser" }
}
{ $description
"Returns a parser that matches a single character that lies within the range of characters given, inclusive." }
{ $example ": digit ( -- parser ) CHAR: 0 CHAR: 9 range ;" } ;
HELP: seq
{ $values
{ "seq" "a sequence of parsers" }
{ "parser" "a parser" }
}
{ $description
"Returns a parser that calls all parsers in the given sequence, in order. The parser succeeds if "
"all the parsers succeed, otherwise it fails. The AST produced is a sequence of the AST produced by "
"the individual parsers." } ;
HELP: choice
{ $values
{ "seq" "a sequence of parsers" }
{ "parser" "a parser" }
}
{ $description
"Returns a parser that will try all the parsers in the sequence, in order, until one succeeds. "
"The resulting AST is that produced by the successful parser." } ;
HELP: repeat0
{ $values
{ "p1" "a parser" }
{ "p2" "a parser" }
}
{ $description
"Returns a parser that parses 0 or more instances of the 'p1' parser. The AST produced is "
"an array of the AST produced by the 'p1' parser. An empty array indicates 0 instances were "
"parsed." } ;
HELP: repeat1
{ $values
{ "p1" "a parser" }
{ "p2" "a parser" }
}
{ $description
"Returns a parser that parses 1 or more instances of the 'p1' parser. The AST produced is "
"an array of the AST produced by the 'p1' parser." } ;
HELP: optional
{ $values
{ "p1" "a parser" }
{ "p2" "a parser" }
}
{ $description
"Returns a parser that parses 0 or 1 instances of the 'p1' parser. The AST produced is "
"'f' if 0 instances are parsed the AST produced is 'f', otherwise it is the AST produced by 'p1'." } ;
HELP: ensure
{ $values
{ "p1" "a parser" }
{ "p2" "a parser" }
}
{ $description
"Returns a parser that succeeds if the 'p1' parser succeeds but does not add anything to the "
"AST and does not move the location in the input string. This can be used for lookahead and "
"disambiguation, along with the " { $link ensure-not } " word." }
{ $example "\"0\" token ensure octal-parser" } ;
HELP: ensure-not
{ $values
{ "p1" "a parser" }
{ "p2" "a parser" }
}
{ $description
"Returns a parser that succeeds if the 'p1' parser fails but does not add anything to the "
"AST and does not move the location in the input string. This can be used for lookahead and "
"disambiguation, along with the " { $link ensure } " word." }
{ $example "\"+\" token \"=\" token ensure-not \"+=\" token 3array seq" } ;
HELP: action
{ $values
{ "p1" "a parser" }
{ "quot" "a quotation with stack effect ( ast -- ast )" }
}
{ $description
"Returns a parser that calls the 'p1' parser and applies the quotation to the AST resulting "
"from that parse. The result of the quotation is then used as the final AST. This can be used "
"for manipulating the parse tree to produce a AST better suited for the task at hand rather than "
"the default AST." }
{ $example "CHAR: 0 CHAR: 9 range [ to-digit ] action" } ;

139
extra/peg/peg-tests.factor Normal file
View File

@ -0,0 +1,139 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test strings namespaces arrays sequences peg peg.private ;
IN: temporary
{ 0 1 2 } [
0 next-id set-global get-next-id get-next-id get-next-id
] unit-test
{ f } [
"endbegin" "begin" token parse
] unit-test
{ "begin" "end" } [
"beginend" "begin" token parse
{ parse-result-ast parse-result-remaining } get-slots
>string
] unit-test
{ f } [
"" CHAR: a CHAR: z range parse
] unit-test
{ f } [
"1bcd" CHAR: a CHAR: z range parse
] unit-test
{ CHAR: a } [
"abcd" CHAR: a CHAR: z range parse parse-result-ast
] unit-test
{ CHAR: z } [
"zbcd" CHAR: a CHAR: z range parse parse-result-ast
] unit-test
{ f } [
"bad" "a" token "b" token 2array seq parse
] unit-test
{ V{ "g" "o" } } [
"good" "g" token "o" token 2array seq parse parse-result-ast
] unit-test
{ "a" } [
"abcd" "a" token "b" token 2array choice parse parse-result-ast
] unit-test
{ "b" } [
"bbcd" "a" token "b" token 2array choice parse parse-result-ast
] unit-test
{ f } [
"cbcd" "a" token "b" token 2array choice parse
] unit-test
{ f } [
"" "a" token "b" token 2array choice parse
] unit-test
{ 0 } [
"" "a" token repeat0 parse parse-result-ast length
] unit-test
{ 0 } [
"b" "a" token repeat0 parse parse-result-ast length
] unit-test
{ V{ "a" "a" "a" } } [
"aaab" "a" token repeat0 parse parse-result-ast
] unit-test
{ f } [
"" "a" token repeat1 parse
] unit-test
{ f } [
"b" "a" token repeat1 parse
] unit-test
{ V{ "a" "a" "a" } } [
"aaab" "a" token repeat1 parse parse-result-ast
] unit-test
{ V{ "a" "b" } } [
"ab" "a" token optional "b" token 2array seq parse parse-result-ast
] unit-test
{ V{ f "b" } } [
"b" "a" token optional "b" token 2array seq parse parse-result-ast
] unit-test
{ f } [
"cb" "a" token optional "b" token 2array seq parse
] unit-test
{ V{ CHAR: a CHAR: b } } [
"ab" "a" token ensure CHAR: a CHAR: z range dup 3array seq parse parse-result-ast
] unit-test
{ f } [
"bb" "a" token ensure CHAR: a CHAR: z range 2array seq parse
] unit-test
{ t } [
"a+b"
"a" token "+" token dup ensure-not 2array seq "++" token 2array choice "b" token 3array seq
parse [ t ] [ f ] if
] unit-test
{ t } [
"a++b"
"a" token "+" token dup ensure-not 2array seq "++" token 2array choice "b" token 3array seq
parse [ t ] [ f ] if
] unit-test
{ t } [
"a+b"
"a" token "+" token "++" token 2array choice "b" token 3array seq
parse [ t ] [ f ] if
] unit-test
{ f } [
"a++b"
"a" token "+" token "++" token 2array choice "b" token 3array seq
parse [ t ] [ f ] if
] unit-test
{ 1 } [
"a" "a" token [ drop 1 ] action parse parse-result-ast
] unit-test
{ V{ 1 1 } } [
"aa" "a" token [ drop 1 ] action dup 2array seq parse parse-result-ast
] unit-test
{ f } [
"b" "a" token [ drop 1 ] action parse
] unit-test

176
extra/peg/peg.factor Normal file
View File

@ -0,0 +1,176 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings namespaces math assocs shuffle vectors combinators.lib ;
IN: peg
TUPLE: parse-result remaining ast ;
GENERIC: parse ( state parser -- result )
<PRIVATE
SYMBOL: ignore
: <parse-result> ( remaining ast -- parse-result )
parse-result construct-boa ;
SYMBOL: next-id
: get-next-id ( -- number )
next-id get-global 0 or dup 1+ next-id set-global ;
TUPLE: parser id ;
: init-parser ( parser -- parser )
get-next-id parser construct-boa over set-delegate ;
TUPLE: token-parser symbol ;
M: token-parser parse ( state parser -- result )
token-parser-symbol 2dup head? [
dup >r length tail-slice r> <parse-result>
] [
2drop f
] if ;
TUPLE: range-parser min max ;
M: range-parser parse ( state parser -- result )
over empty? [
2drop f
] [
0 pick nth dup rot
{ range-parser-min range-parser-max } get-slots between? [
[ 1 tail-slice ] dip <parse-result>
] [
2drop f
] if
] if ;
TUPLE: seq-parser parsers ;
: do-seq-parser ( result parser -- result )
[ dup parse-result-remaining ] dip parse [
[ parse-result-remaining swap set-parse-result-remaining ] 2keep
parse-result-ast dup ignore = [ drop ] [ swap [ parse-result-ast push ] keep ] if
] [
drop f
] if* ;
: (seq-parser) ( result parsers -- result )
dup empty? not pick and [
unclip swap [ do-seq-parser ] dip (seq-parser)
] [
drop
] if ;
M: seq-parser parse ( state parser -- result )
seq-parser-parsers [ V{ } clone <parse-result> ] dip (seq-parser) ;
TUPLE: choice-parser parsers ;
: (choice-parser) ( state parsers -- result )
dup empty? [
2drop f
] [
unclip pick swap parse [
2nip
] [
(choice-parser)
] if*
] if ;
M: choice-parser parse ( state parser -- result )
choice-parser-parsers (choice-parser) ;
TUPLE: repeat0-parser p1 ;
: (repeat-parser) ( parser result -- result )
2dup parse-result-remaining swap parse [
[ parse-result-remaining swap set-parse-result-remaining ] 2keep
parse-result-ast swap [ parse-result-ast push ] keep
(repeat-parser)
] [
nip
] if* ;
: clone-result ( result -- result )
{ parse-result-remaining parse-result-ast }
get-slots 1vector <parse-result> ;
M: repeat0-parser parse ( state parser -- result )
repeat0-parser-p1 2dup parse [
nipd clone-result (repeat-parser)
] [
drop V{ } clone <parse-result>
] if* ;
TUPLE: repeat1-parser p1 ;
M: repeat1-parser parse ( state parser -- result )
repeat1-parser-p1 tuck parse dup [ clone-result (repeat-parser) ] [ nip ] if ;
TUPLE: optional-parser p1 ;
M: optional-parser parse ( state parser -- result )
dupd optional-parser-p1 parse swap f <parse-result> or ;
TUPLE: ensure-parser p1 ;
M: ensure-parser parse ( state parser -- result )
dupd ensure-parser-p1 parse [
ignore <parse-result>
] [
drop f
] if ;
TUPLE: ensure-not-parser p1 ;
M: ensure-not-parser parse ( state parser -- result )
dupd ensure-not-parser-p1 parse [
drop f
] [
ignore <parse-result>
] if ;
TUPLE: action-parser p1 quot ;
M: action-parser parse ( state parser -- result )
tuck action-parser-p1 parse dup [
dup parse-result-ast rot action-parser-quot call
swap [ set-parse-result-ast ] keep
] [
nip
] if ;
PRIVATE>
: token ( string -- parser )
token-parser construct-boa init-parser ;
: range ( min max -- parser )
range-parser construct-boa init-parser ;
: seq ( seq -- parser )
seq-parser construct-boa init-parser ;
: choice ( seq -- parser )
choice-parser construct-boa init-parser ;
: repeat0 ( parser -- parser )
repeat0-parser construct-boa init-parser ;
: repeat1 ( parser -- parser )
repeat1-parser construct-boa init-parser ;
: optional ( parser -- parser )
optional-parser construct-boa init-parser ;
: ensure ( parser -- parser )
ensure-parser construct-boa init-parser ;
: ensure-not ( parser -- parser )
ensure-not-parser construct-boa init-parser ;
: action ( parser quot -- parser )
action-parser construct-boa init-parser ;

41
extra/raptor/config.factor
View File

@ -1,5 +1,7 @@
USING: namespaces unix.linux.if unix.linux.ifreq unix.linux.route ;
USING: namespaces threads
unix.process unix.linux.if unix.linux.ifreq unix.linux.route
raptor.cron ;
IN: raptor
@ -24,21 +26,40 @@ IN: raptor
configure-route
] networking-hook set-global
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Filesystems
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
"/dev/hda1" root-device set-global
{ "/dev/hda5" } swap-devices set-global
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! boot-hook
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[
start-wait-loop
! rcS.d
"mountvirtfs" start-service
"hostname.sh" start-service
! "hostname.sh" start-service
"narodnik" set-hostname
"keymap.sh" start-service
"linux-restricted-modules-common" start-service
"udev" start-service
"mountdevsubfs" start-service
"module-init-tools" start-service
"procps.sh" start-service
"checkroot.sh" start-service
! "checkroot.sh" start-service
activate-swap
mount-root
"mtab" start-service
"checkfs.sh" start-service
"mountall.sh" start-service
@ -76,11 +97,17 @@ IN: raptor
"rmnologin" start-service
schedule-cron-jobs
start-listeners
start-gettys
[ [ "/dev/tty2" tty-listener ] forever ] in-thread
[ [ "/dev/tty3" tty-listener ] forever ] in-thread
[ [ "/dev/tty4" tty-listener ] forever ] in-thread
[ [ "/dev/tty5" getty ] forever ] in-thread
[ [ "/dev/tty6" getty ] forever ] in-thread
] boot-hook set-global
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! reboot-hook
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[
@ -108,6 +135,8 @@ IN: raptor
"reboot" stop-service
] reboot-hook set-global
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! shutdown-hook
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[

16
extra/raptor/cron/cron.factor
View File

@ -1,5 +1,6 @@
USING: kernel threads sequences calendar combinators.cleave combinators.lib ;
USING: kernel namespaces threads sequences calendar
combinators.cleave combinators.lib ;
IN: raptor.cron
@ -46,3 +47,16 @@ C: <when> when
: schedule ( when quot -- ) [ recurring-job ] curry curry in-thread ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: cron-jobs-hourly
SYMBOL: cron-jobs-daily
SYMBOL: cron-jobs-weekly
SYMBOL: cron-jobs-monthly
: schedule-cron-jobs ( -- )
{ 17 } f f f f <when> [ cron-jobs-hourly get call ] schedule
{ 25 } { 6 } f f f <when> [ cron-jobs-daily get call ] schedule
{ 47 } { 6 } f f { 7 } <when> [ cron-jobs-weekly get call ] schedule
{ 52 } { 6 } { 1 } f f <when> [ cron-jobs-monthly get call ] schedule ;

63
extra/raptor/cronjobs.factor
View File

@ -1,47 +1,38 @@
USING: kernel threads arrays sequences combinators.cleave raptor raptor.cron ;
USING: kernel namespaces threads arrays sequences combinators.cleave
raptor raptor.cron ;
IN: raptor
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: fork-exec-args-wait ( args -- ) [ first ] [ ] bi fork-exec-wait ;
: run-script ( path -- ) 1array [ fork-exec-args-wait ] curry in-thread ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: cron-hourly ( -- ) ;
: cron-daily ( -- )
{ "/etc/cron.daily/apt"
"/etc/cron.daily/aptitude"
"/etc/cron.daily/bsdmainutils"
"/etc/cron.daily/find.notslocate"
"/etc/cron.daily/logrotate"
"/etc/cron.daily/man-db"
"/etc/cron.daily/ntp-server"
"/etc/cron.daily/slocate"
"/etc/cron.daily/standard"
"/etc/cron.daily/sysklogd"
"/etc/cron.daily/tetex-bin" }
[ 1array [ fork-exec-args-wait ] in-thread drop ] each ;
[
"/etc/cron.daily/apt" run-script
"/etc/cron.daily/aptitude" run-script
"/etc/cron.daily/bsdmainutils" run-script
"/etc/cron.daily/find.notslocate" run-script
"/etc/cron.daily/logrotate" run-script
"/etc/cron.daily/man-db" run-script
"/etc/cron.daily/ntp-server" run-script
"/etc/cron.daily/slocate" run-script
"/etc/cron.daily/standard" run-script
"/etc/cron.daily/sysklogd" run-script
"/etc/cron.daily/tetex-bin" run-script
] cron-jobs-daily set-global
: cron-weekly ( -- )
{ "/etc/cron.weekly/cvs"
"/etc/cron.weekly/man-db"
"/etc/cron.weekly/ntp-server"
"/etc/cron.weekly/popularity-contest"
"/etc/cron.weekly/sysklogd" }
[ 1array [ fork-exec-args-wait ] in-thread drop ] each ;
[
"/etc/cron.weekly/cvs" run-script
"/etc/cron.weekly/man-db" run-script
"/etc/cron.weekly/ntp-server" run-script
"/etc/cron.weekly/popularity-contest" run-script
"/etc/cron.weekly/sysklogd" run-script
] cron-jobs-weekly set-global
: cron-monthly ( -- )
{ "/etc/cron.monthly/scrollkeeper"
"/etc/cron.monthly/standard" }
[ 1array [ fork-exec-args-wait ] in-thread drop ] each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: schedule-cron-jobs ( -- )
{ 17 } f f f f <when> [ cron-hourly ] schedule
{ 25 } { 6 } f f f <when> [ cron-daily ] schedule
{ 47 } { 6 } f f { 7 } <when> [ cron-weekly ] schedule
{ 52 } { 6 } { 1 } f f <when> [ cron-monthly ] schedule ;
[
"/etc/cron.monthly/scrollkeeper" run-script
"/etc/cron.monthly/standard" run-script
] cron-jobs-monthly set-global

51
extra/raptor/raptor.factor
View File

@ -1,5 +1,6 @@
USING: kernel parser namespaces threads unix.process combinators.cleave ;
USING: kernel parser namespaces threads sequences unix unix.process
combinators.cleave bake ;
IN: raptor
@ -10,29 +11,31 @@ SYMBOL: reboot-hook
SYMBOL: shutdown-hook
SYMBOL: networking-hook
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: reload-raptor-config ( -- )
"/etc/raptor/config.factor" run-file
"/etc/raptor/cronjobs.factor" run-file ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: sequences unix ;
: fork-exec-wait ( pathname args -- )
fork dup 0 = [ drop exec drop ] [ 2nip wait-for-pid drop ] if ;
: fork-exec-args-wait ( args -- ) [ first ] [ ] bi fork-exec-wait ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: forever ( quot -- ) [ call ] [ forever ] bi ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: start-service ( name -- ) "/etc/init.d/" swap " start" 3append system drop ;
: stop-service ( name -- ) "/etc/init.d/" swap " stop" 3append system drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: fork-exec-wait ( pathname args -- )
fork dup 0 = [ drop exec drop ] [ 2nip wait-for-pid ] if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: respawn ( pathname args -- ) [ fork-exec-wait ] [ respawn ] 2bi ;
: start-gettys ( -- )
[ "/sbin/getty" { "getty" "38400" "tty5" } respawn ] in-thread
[ "/sbin/getty" { "getty" "38400" "tty6" } respawn ] in-thread ;
: getty ( tty -- ) `{ "/sbin/getty" "38400" , } fork-exec-args-wait ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -40,23 +43,31 @@ USING: io io.files io.streams.lines io.streams.plain io.streams.duplex
listener ;
: tty-listener ( tty -- )
[ <file-reader> <line-reader> ]
[ <file-writer> <plain-writer> ]
bi <duplex-stream> [ listener ] with-stream ;
[ <file-reader> ] [ <file-writer> ] bi <duplex-stream>
[ listener ] with-stream ;
: forever ( quot -- ) [ call ] [ forever ] bi ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: start-listeners ( -- )
[ [ "/dev/tty2" tty-listener ] forever ] in-thread
[ [ "/dev/tty3" tty-listener ] forever ] in-thread
[ [ "/dev/tty4" tty-listener ] forever ] in-thread ;
USING: unix.linux.swap unix.linux.fs ;
SYMBOL: root-device
SYMBOL: swap-devices
: activate-swap ( -- ) swap-devices get [ 0 swapon drop ] each ;
: mount-root ( -- ) root-device get "/" "ext3" MS_REMOUNT f mount drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: start-networking ( -- ) networking-hook get call ;
: set-hostname ( name -- ) `{ "/bin/hostname" , } fork-exec-args-wait ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: boot ( -- ) boot-hook get call ;
: reboot ( -- ) reboot-hook get call ;
: shutdown ( -- ) shutdown-hook get call ;
MAIN: boot

17
extra/raptor/readme-0.1.1
View File

@ -8,9 +8,22 @@ Raptor Linux is a mod of Ubuntu 6.06 (Dapper Drake)
This is unlikely to work on another version of Ubuntu, much less
another Linux distribution.
*** Features ***
* /sbin/init is replaced with Factor
* Virtual terminals managed by Factor
* Listeners run on virtual terminals
* Native support for static ip networking
* Crontab replacement
*** Install ***
# mkdir -v /etc/raptor
# cp -v /scratch/factor/extra/raptor/{config,cronjobs}.factor /etc/raptor
( scratchpad ) USE: raptor
( scratchpad ) reload-raptor-config
( scratchpad ) save
# mv -v /sbin/{init,init.orig}
@ -19,10 +32,6 @@ another Linux distribution.
# cp -v /scratch/factor/factor.image /sbin/init.image
# mkdir -v /etc/raptor
# cp -v /scratch/factor/extra/raptor/config.factor /etc/raptor/config.factor
*** Static IP networking ***
If you use a static IP in your network then Factor can take care of

77
extra/regexp/regexp-tests.factor Normal file
View File

@ -0,0 +1,77 @@
USING: regexp tools.test ;
IN: regexp-tests
[ f ] [ "b" "a*" matches? ] unit-test
[ t ] [ "" "a*" matches? ] unit-test
[ t ] [ "a" "a*" matches? ] unit-test
[ t ] [ "aaaaaaa" "a*" matches? ] unit-test
[ f ] [ "ab" "a*" matches? ] unit-test
[ t ] [ "abc" "abc" matches? ] unit-test
[ t ] [ "a" "a|b|c" matches? ] unit-test
[ t ] [ "b" "a|b|c" matches? ] unit-test
[ t ] [ "c" "a|b|c" matches? ] unit-test
[ f ] [ "c" "d|e|f" matches? ] unit-test
[ f ] [ "aa" "a|b|c" matches? ] unit-test
[ f ] [ "bb" "a|b|c" matches? ] unit-test
[ f ] [ "cc" "a|b|c" matches? ] unit-test
[ f ] [ "cc" "d|e|f" matches? ] unit-test
[ f ] [ "" "a+" matches? ] unit-test
[ t ] [ "a" "a+" matches? ] unit-test
[ t ] [ "aa" "a+" matches? ] unit-test
[ t ] [ "" "a?" matches? ] unit-test
[ t ] [ "a" "a?" matches? ] unit-test
[ f ] [ "aa" "a?" matches? ] unit-test
[ f ] [ "" "." matches? ] unit-test
[ t ] [ "a" "." matches? ] unit-test
[ t ] [ "." "." matches? ] unit-test
[ f ] [ "" ".+" matches? ] unit-test
[ t ] [ "a" ".+" matches? ] unit-test
[ t ] [ "ab" ".+" matches? ] unit-test
[ t ] [ "" "a|b*|c+|d?" matches? ] unit-test
[ t ] [ "a" "a|b*|c+|d?" matches? ] unit-test
[ t ] [ "c" "a|b*|c+|d?" matches? ] unit-test
[ t ] [ "cc" "a|b*|c+|d?" matches? ] unit-test
[ f ] [ "ccd" "a|b*|c+|d?" matches? ] unit-test
[ t ] [ "d" "a|b*|c+|d?" matches? ] unit-test
[ t ] [ "foo" "foo|bar" matches? ] unit-test
[ t ] [ "bar" "foo|bar" matches? ] unit-test
[ f ] [ "foobar" "foo|bar" matches? ] unit-test
[ f ] [ "" "(a)" matches? ] unit-test
[ t ] [ "a" "(a)" matches? ] unit-test
[ f ] [ "aa" "(a)" matches? ] unit-test
[ t ] [ "aa" "(a*)" matches? ] unit-test
[ f ] [ "aababaaabbac" "(a|b)+" matches? ] unit-test
[ t ] [ "ababaaabba" "(a|b)+" matches? ] unit-test
[ f ] [ "" "a{1}" matches? ] unit-test
[ t ] [ "a" "a{1}" matches? ] unit-test
[ f ] [ "aa" "a{1}" matches? ] unit-test
[ f ] [ "a" "a{2,}" matches? ] unit-test
[ t ] [ "aaa" "a{2,}" matches? ] unit-test
[ t ] [ "aaaa" "a{2,}" matches? ] unit-test
[ t ] [ "aaaaa" "a{2,}" matches? ] unit-test
[ t ] [ "" "a{,2}" matches? ] unit-test
[ t ] [ "a" "a{,2}" matches? ] unit-test
[ t ] [ "aa" "a{,2}" matches? ] unit-test
[ f ] [ "aaa" "a{,2}" matches? ] unit-test
[ f ] [ "aaaa" "a{,2}" matches? ] unit-test
[ f ] [ "aaaaa" "a{,2}" matches? ] unit-test
[ f ] [ "" "a{1,3}" matches? ] unit-test
[ t ] [ "a" "a{1,3}" matches? ] unit-test
[ t ] [ "aa" "a{1,3}" matches? ] unit-test
[ t ] [ "aaa" "a{1,3}" matches? ] unit-test
[ f ] [ "aaaa" "a{1,3}" matches? ] unit-test

132
extra/regexp/regexp.factor Normal file
View File

@ -0,0 +1,132 @@
USING: combinators kernel lazy-lists math math.parser
namespaces parser parser-combinators parser-combinators.simple
promises sequences strings ;
USING: continuations io prettyprint ;
IN: regexp
: 'any-char'
"." token [ drop any-char-parser ] <@ ;
: 'escaped-char'
"\\" token any-char-parser &> ;
: 'ordinary-char'
[ "*+?|(){}" member? not ] satisfy ;
: 'char' 'escaped-char' 'ordinary-char' <|> ;
: 'string' 'char' <+> [ >string token ] <@ ;
: exactly-n ( parser n -- parser' )
swap <repetition> and-parser construct-boa ;
: at-most-n ( parser n -- parser' )
dup zero? [
2drop epsilon
] [
2dup exactly-n
-rot 1- at-most-n <|>
] if ;
: at-least-n ( parser n -- parser' )
dupd exactly-n swap <*> <&> ;
: from-m-to-n ( parser m n -- parser' )
>r [ exactly-n ] 2keep r> swap - at-most-n <&> ;
DEFER: 'regexp'
TUPLE: group-result str ;
C: <group-result> group-result
: 'grouping'
"(" token
'regexp' [ [ <group-result> ] <@ ] <@
")" token <& &> ;
: 'term'
'any-char'
'string' <|>
'grouping' <|>
<+> [
dup length 1 =
[ first ] [ and-parser construct-boa ] if
] <@ ;
: 'interval'
'term'
"{" token
'integer' <?> &>
"," token <?> <:&:>
'integer' <?> <:&:>
"}" token <& <&> [
first2 dup length {
{ 1 [ first exactly-n ] }
{ 2 [ first2 dup integer?
[ nip at-most-n ]
[ drop at-least-n ] if ] }
{ 3 [ first3 nip from-m-to-n ] }
} case
] <@ ;
: 'character-range'
any-char-parser "-" token <& any-char-parser &> ;
: 'character-class-inside'
any-char-parser
'character-range' <|> ;
: 'character-class-inclusive'
"[" token
'character-class-inside'
"]" token ;
: 'character-class-exclusive'
"[^" token
'character-class-inside'
"]" token ;
: 'character-class'
'character-class-inclusive'
'character-class-exclusive' <|> ;
: 'repetition'
'term'
[ "*+?" member? ] satisfy <&> [
first2 {
{ CHAR: * [ <*> ] }
{ CHAR: + [ <+> ] }
{ CHAR: ? [ <?> ] }
} case
] <@ ;
: 'simple' 'term' 'repetition' <|> 'interval' <|> ;
LAZY: 'union' ( -- parser )
'simple'
'simple' "|" token 'union' &> <&> [ first2 <|> ] <@
<|> ;
LAZY: 'regexp' ( -- parser )
'repetition' 'union' <|> ;
: <regexp> 'regexp' just parse-1 ;
GENERIC: >regexp ( obj -- parser )
M: string >regexp 'regexp' just parse-1 ;
M: object >regexp ;
: matches? ( string regexp -- ? ) >regexp just parse nil? not ;
: parse-regexp ( accum end -- accum )
lexer get dup skip-blank [
[ index* dup 1+ swap ] 2keep swapd subseq swap
] change-column <regexp> parsed ;
: R/ CHAR: / parse-regexp ; parsing
: R| CHAR: | parse-regexp ; parsing
: R" CHAR: " parse-regexp ; parsing
: R' CHAR: ' parse-regexp ; parsing
: R` CHAR: ` parse-regexp ; parsing

22
extra/tools/annotations/annotations.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words parser io inspector quotations sequences
prettyprint continuations ;
prettyprint continuations effects ;
IN: tools.annotations
: annotate ( word quot -- )
@ -9,17 +9,29 @@ IN: tools.annotations
swap define-compound do-parse-hook ;
inline
: entering ( str -- ) "! Entering: " write print .s flush ;
: entering ( str -- )
"/-- Entering: " write dup .
stack-effect [
>r datastack r> effect-in length tail* stack.
] [
.s
] if* "\\--" print flush ;
: leaving ( str -- ) "! Leaving: " write print .s flush ;
: leaving ( str -- )
"/-- Leaving: " write dup .
stack-effect [
>r datastack r> effect-out length tail* stack.
] [
.s
] if* "\\--" print flush ;
: (watch) ( str def -- def )
: (watch) ( word def -- def )
over [ entering ] curry
rot [ leaving ] curry
swapd 3append ;
: watch ( word -- )
dup word-name swap [ (watch) ] annotate ;
dup [ (watch) ] annotate ;
: breakpoint ( word -- )
[ \ break add* ] annotate ;

12
extra/tools/deploy/deploy.factor
View File

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

29
extra/tools/deploy/macosx/macosx.factor
View File

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

4
extra/tools/deploy/shaker/shaker.factor
View File

@ -111,6 +111,10 @@ SYMBOL: deploy-vocab
builtins ,
strip-io? [ io-backend , ] unless
deploy-compiler? get [
"callbacks" "alien.compiler" lookup ,
] when
strip-dictionary? [
{
dictionary

2
extra/tools/test/ui/ui.factor
View File

@ -1,5 +1,5 @@
USING: dlists ui.gadgets kernel ui namespaces io.streams.string
io ui.private ;
io ;
IN: tools.test.ui
! We can't print to stdio here because that might be a pane

14
extra/ui/cocoa/cocoa.factor
View File

@ -5,7 +5,7 @@ kernel memory namespaces cocoa.messages cocoa.runtime
cocoa.subclassing cocoa.pasteboard cocoa.types cocoa.windows
cocoa.classes cocoa.application sequences system ui ui.backend
ui.clipboards ui.gadgets ui.gadgets.worlds ui.cocoa.views
core-foundation ;
core-foundation threads ;
IN: ui.cocoa
TUPLE: cocoa-ui-backend ;
@ -19,7 +19,7 @@ SYMBOL: stop-after-last-window?
: 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
] when ;
@ -60,11 +60,19 @@ M: cocoa-ui-backend set-title ( string world -- )
drop
] if ;
M: cocoa-ui-backend (open-world-window) ( world -- )
M: cocoa-ui-backend (open-window) ( world -- )
dup gadget-window
dup auto-position
world-handle second f -> makeKeyAndOrderFront: ;
M: cocoa-ui-backend (close-window) ( handle -- )
first unregister-window ;
M: cocoa-ui-backend close-window ( gadget -- )
find-world [
world-handle second f -> performClose:
] when* ;
M: cocoa-ui-backend raise-window ( world -- )
world-handle [
second dup f -> orderFront: -> makeKeyWindow

11
extra/ui/cocoa/views/views.factor
View File

@ -3,7 +3,8 @@
USING: alien arrays assocs cocoa kernel math cocoa.messages
cocoa.subclassing cocoa.classes cocoa.views cocoa.application
cocoa.pasteboard cocoa.types cocoa.windows sequences ui
ui.gadgets ui.gadgets.worlds ui.gestures core-foundation ;
ui.gadgets ui.gadgets.worlds ui.gestures core-foundation
threads ;
IN: ui.cocoa.views
: send-mouse-moved ( view event -- )
@ -313,8 +314,6 @@ CLASS: {
{ "dealloc" "void" { "id" "SEL" }
[
drop
dup window stop-world
dup unregister-window
dup remove-observer
SUPER-> dealloc
]
@ -347,6 +346,12 @@ CLASS: {
forget-rollover
2nip -> object -> contentView window unfocus-world
]
}
{ "windowShouldClose:" "bool" { "id" "SEL" "id" }
[
2nip -> contentView window ungraft t
]
} ;
: install-window-delegate ( window -- )

2
extra/ui/gadgets/editors/editors-tests.factor
View File

@ -1,5 +1,5 @@
USING: ui.gadgets.editors tools.test kernel io io.streams.plain
definitions namespaces ui.gadgets ui.private
definitions namespaces ui.gadgets
ui.gadgets.grids prettyprint documents ui.gestures
tools.test.inference tools.test.ui models ;

56
extra/ui/gadgets/editors/editors.factor
View File

@ -4,7 +4,7 @@ USING: arrays documents ui.clipboards ui.commands ui.gadgets
ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels
ui.gadgets.scrollers ui.gadgets.theme ui.render ui.gestures io
kernel math models namespaces opengl opengl.gl sequences strings
io.styles math.vectors sorting colors combinators ;
io.styles math.vectors sorting colors combinators assocs ;
IN: ui.gadgets.editors
TUPLE: editor
@ -94,8 +94,11 @@ M: editor ungraft*
rot editor-line x>offset ,
] { } make ;
: clicked-loc ( editor -- loc )
[ hand-rel ] keep point>loc ;
: click-loc ( editor model -- )
>r [ hand-rel ] keep point>loc r> set-model ;
>r clicked-loc r> set-model ;
: focus-editor ( editor -- )
t over set-editor-focused? relayout-1 ;
@ -244,11 +247,37 @@ M: editor user-input*
M: editor gadget-text* editor-string % ;
: start-selection ( editor -- )
dup editor-caret click-loc ;
: extend-selection ( editor -- )
dup request-focus start-selection ;
dup request-focus dup editor-caret click-loc ;
: mouse-elt ( -- elelement )
hand-click# get {
{ 2 T{ one-word-elt } }
{ 3 T{ one-line-elt } }
} at T{ one-char-elt } or ;
: drag-direction? ( loc editor -- ? )
editor-mark* <=> 0 < ;
: drag-selection-caret ( loc editor element -- loc )
>r [ drag-direction? ] 2keep
gadget-model
r> prev/next-elt ? ;
: drag-selection-mark ( loc editor element -- loc )
>r [ drag-direction? not ] 2keep
nip dup editor-mark* swap gadget-model
r> prev/next-elt ? ;
: drag-caret&mark ( editor -- caret mark )
dup clicked-loc swap mouse-elt
[ drag-selection-caret ] 3keep
drag-selection-mark ;
: drag-selection ( editor -- )
dup drag-caret&mark
pick editor-mark set-model
swap editor-caret set-model ;
: editor-cut ( editor clipboard -- )
dupd gadget-copy remove-selection ;
@ -296,17 +325,10 @@ M: editor gadget-text* editor-string % ;
dup T{ one-word-elt } select-elt
] unless gadget-selection ;
: (position-caret) ( editor -- )
dup extend-selection
dup editor-mark click-loc ;
: position-caret ( editor -- )
hand-click# get {
{ 1 [ (position-caret) ] }
{ 2 [ T{ one-word-elt } select-elt ] }
{ 3 [ T{ one-line-elt } select-elt ] }
[ 2drop ]
} case ;
mouse-elt dup T{ one-char-elt } =
[ drop dup extend-selection dup editor-mark click-loc ]
[ select-elt ] if ;
: insert-newline "\n" swap user-input ;
@ -408,7 +430,7 @@ editor "caret-motion" f {
editor "selection" f {
{ T{ button-down f { S+ } } extend-selection }
{ T{ drag } start-selection }
{ T{ drag } drag-selection }
{ T{ gain-focus } focus-editor }
{ T{ lose-focus } unfocus-editor }
{ T{ delete-action } remove-selection }

2
extra/ui/gadgets/gadgets-tests.factor
View File

@ -2,7 +2,7 @@ IN: temporary
USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test
namespaces models kernel tools.test.inference dlists math
math.parser ui sequences hashtables assocs io arrays
prettyprint io.streams.string ui.private ;
prettyprint io.streams.string ;
[ T{ rect f { 10 10 } { 20 20 } } ]
[

4
extra/ui/gadgets/incremental/incremental.factor
View File

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

2
extra/ui/gadgets/scrollers/scrollers-tests.factor
View File

@ -1,5 +1,5 @@
IN: temporary
USING: ui.gadgets ui.gadgets.scrollers ui.private
USING: ui.gadgets ui.gadgets.scrollers
namespaces tools.test kernel models ui.gadgets.viewports
ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames
ui.gadgets.sliders math math.vectors arrays sequences

19
extra/ui/gestures/gestures.factor Normal file → Executable file
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel math models namespaces
sequences words strings system hashtables math.parser
math.vectors tuples classes ui.gadgets timers ;
math.vectors tuples classes ui.gadgets timers combinators.lib ;
IN: ui.gestures
: set-gestures ( class hash -- ) "gestures" set-word-prop ;
@ -176,9 +176,22 @@ drag-timer construct-empty drag-timer set-global
: hand-click-rel ( gadget -- loc )
hand-click-loc get-global swap screen-loc v- ;
: multi-click-timeout? ( -- ? )
millis hand-last-time get - double-click-timeout get <= ;
: multi-click-button? ( button -- button ? )
dup hand-last-button get = ;
: multi-click-position? ( -- ? )
hand-loc get hand-click-loc get v- norm 10 <= ;
: multi-click? ( button -- ? )
millis hand-last-time get - double-click-timeout get <=
swap hand-last-button get = and ;
{
[ multi-click-timeout? ]
[ multi-click-button? ]
[ multi-click-position? ]
[ multi-click-position? ]
} && nip ;
: update-click# ( button -- )
global [

2
extra/ui/tools/browser/browser-tests.factor
View File

@ -1,6 +1,6 @@
IN: temporary
USING: tools.test tools.test.ui ui.tools.browser
tools.test.inference ui.private ;
tools.test.inference ;
{ 0 1 } [ <browser-gadget> ] unit-test-effect
[ ] [ <browser-gadget> [ ] with-grafted-gadget ] unit-test

7
extra/ui/tools/deploy/deploy.factor
View File

@ -77,7 +77,8 @@ TUPLE: deploy-gadget vocab settings ;
: com-deploy ( gadget -- )
dup com-save
find-deploy-vocab [ deploy ] curry call-listener ;
dup find-deploy-vocab [ deploy ] curry call-listener
close-window ;
: com-help ( -- )
"ui-deploy" help-window ;
@ -86,7 +87,11 @@ TUPLE: deploy-gadget vocab settings ;
{ +nullary+ t }
} define-command
: com-close ( gadget -- )
close-window ;
deploy-gadget "toolbar" f {
{ f com-close }
{ f com-help }
{ f com-revert }
{ f com-save }

2
extra/ui/tools/listener/listener-tests.factor
View File

@ -1,7 +1,7 @@
USING: continuations documents ui.tools.interactor
ui.tools.listener hashtables kernel namespaces parser sequences
timers tools.test ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.panes vocabs words tools.test.ui ui.private ;
ui.gadgets.panes vocabs words tools.test.ui ;
IN: temporary
timers [ init-timers ] unless

2
extra/ui/tools/operations/operations.factor
View File

@ -64,6 +64,7 @@ V{ } clone operations set-global
{ +keyboard+ T{ key-down f { C+ } "E" } }
{ +primary+ t }
{ +secondary+ t }
{ +listener+ t }
} define-operation
UNION: definition word method-spec link ;
@ -72,6 +73,7 @@ UNION: editable-definition definition vocab vocab-link ;
[ editable-definition? ] \ edit H{
{ +keyboard+ T{ key-down f { C+ } "E" } }
{ +listener+ t }
} define-operation
UNION: reloadable-definition definition pathname ;

2
extra/ui/tools/search/search-tests.factor
View File

@ -1,6 +1,6 @@
USING: assocs ui.tools.search help.topics io.files io.styles
kernel namespaces sequences source-files threads timers
tools.test ui.gadgets ui.gestures ui.private vocabs
tools.test ui.gadgets ui.gestures vocabs
vocabs.loader words tools.test.ui debugger ;
IN: temporary

2
extra/ui/tools/tools-tests.factor
View File

@ -2,7 +2,7 @@ USING: ui.tools ui.tools.interactor ui.tools.listener
ui.tools.search ui.tools.workspace kernel models namespaces
sequences timers tools.test ui.gadgets ui.gadgets.buttons
ui.gadgets.labelled ui.gadgets.presentations
ui.gadgets.scrollers vocabs tools.test.ui ui ui.private ;
ui.gadgets.scrollers vocabs tools.test.ui ui ;
IN: temporary
[

14
extra/ui/tools/tools.factor
View File

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

2
extra/ui/tools/walker/walker-tests.factor
View File

@ -1,6 +1,6 @@
USING: arrays continuations ui.tools.listener ui.tools.walker
ui.tools.workspace inspector kernel namespaces sequences threads
listener tools.test ui ui.gadgets ui.gadgets.worlds ui.private
listener tools.test ui ui.gadgets ui.gadgets.worlds
ui.gadgets.packs vectors ui.tools tools.interpreter
tools.interpreter.debug tools.test.inference tools.test.ui ;
IN: temporary

9
extra/ui/tools/workspace/workspace.factor
View File

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

35
extra/ui/ui.factor
View File

@ -4,7 +4,7 @@ USING: arrays assocs io kernel math models namespaces
prettyprint dlists sequences threads sequences words timers
debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
ui.gestures ui.backend ui.render continuations init
combinators ;
combinators hashtables ;
IN: ui
! Assoc mapping aliens to gadgets
@ -28,8 +28,6 @@ SYMBOL: windows
: unregister-window ( handle -- )
windows global [ [ first = not ] curry* subset ] change-at ;
<PRIVATE
: raised-window ( world -- )
windows get-global [ second eq? ] curry* find drop
windows get-global [ length 1- ] keep exchange ;
@ -67,18 +65,6 @@ M: world ungraft*
dup world-handle (close-window)
reset-world ;
PRIVATE>
: 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 ;
: close-window ( gadget -- )
find-world [ ungraft ] when* ;
: find-window ( quot -- world )
windows get values
[ gadget-child swap call ] curry* find-last nip ; inline
@ -90,8 +76,6 @@ SYMBOL: ui-hook
<dlist> \ layout-queue set-global
V{ } clone windows set-global ;
<PRIVATE
: restore-gadget-later ( gadget -- )
dup gadget-graft-state {
{ { f f } [ ] }
@ -130,7 +114,7 @@ SYMBOL: ui-hook
layout-queue [
dup layout find-world [ , ] when*
] dlist-slurp
] { } make ;
] { } make prune ;
: redraw-worlds ( seq -- )
[ dup update-hand draw-world ] each ;
@ -146,17 +130,26 @@ SYMBOL: ui-hook
: notify-queued ( -- )
graft-queue [ notify ] dlist-slurp ;
PRIVATE>
: ui-step ( -- )
[
do-timers
notify-queued
layout-queued
redraw-worlds
10 sleep
] 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 ( -- )
init-timers
restore-windows? [

16
extra/ui/windows/windows.factor
View File

@ -94,8 +94,7 @@ SYMBOL: mouse-captured
3drop window draw-world ;
: handle-wm-size ( hWnd uMsg wParam lParam -- )
[ lo-word ] keep hi-word make-RECT get-RECT-dimensions 2array
2nip
[ lo-word ] keep hi-word make-RECT get-RECT-dimensions 2array 2nip
dup { 0 0 } = [ 2drop ] [ swap window set-gadget-dim ui-step ] if ;
: wm-keydown-codes ( -- key )
@ -348,7 +347,10 @@ M: windows-ui-backend (close-window)
: event-loop ( msg -- )
{
{ [ 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 ] }
{ [ t ] [
dup TranslateMessage drop
@ -381,7 +383,7 @@ M: windows-ui-backend (close-window)
>r class-name-ptr get-global f r>
>r >r >r ex-style r> r>
WS_CLIPSIBLINGS WS_CLIPCHILDREN bitor style bitor
0 0 r>
CW_USEDEFAULT dup r>
get-RECT-dimensions
f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ;
@ -397,8 +399,10 @@ M: windows-ui-backend (close-window)
GetDoubleClickTime double-click-timeout set-global ;
: cleanup-win32-ui ( -- )
class-name-ptr get-global f UnregisterClass drop
class-name-ptr get-global [ free ] when*
class-name-ptr get-global [
dup f UnregisterClass drop
free
] when*
f class-name-ptr set-global ;
: setup-pixel-format ( hdc -- )

14
extra/ui/x11/x11.factor
View File

@ -5,7 +5,7 @@ ui.clipboards ui.gadgets.worlds assocs kernel math namespaces
opengl sequences strings x11.xlib x11.events x11.xim x11.glx
x11.clipboard x11.constants x11.windows io.utf8 combinators
debugger system command-line ui.render math.vectors tuples
opengl.gl ;
opengl.gl threads ;
IN: ui.x11
TUPLE: x11-ui-backend ;
@ -158,18 +158,14 @@ M: world selection-request-event
{ [ t ] [ drop send-notify-failure ] }
} cond ;
: close-window ( handle -- )
M: x11-ui-backend (close-window) ( handle -- )
dup x11-handle-xic XDestroyIC
dup x11-handle-glx destroy-glx
x11-handle-window dup unregister-window
destroy-window ;
M: world client-event
swap close-box? [
dup world-handle >r stop-world r> close-window
] [
drop
] if ;
swap close-box? [ ungraft ] [ drop ] if ;
: gadget-window ( world -- )
dup world-loc over rect-dim glx-window
@ -182,7 +178,7 @@ M: world client-event
next-event dup
None XFilterEvent zero? [ drop wait-event ] unless
] [
ui-step wait-event
ui-step 10 sleep wait-event
] if ;
: do-events ( -- )
@ -222,7 +218,7 @@ M: x11-ui-backend set-title ( string world -- )
world-handle x11-handle-window swap dpy get -rot
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
world-handle x11-handle-window dup set-closable map-window ;

25
extra/unix/linux/fs/fs.factor Normal file
View File

@ -0,0 +1,25 @@
USING: alien.syntax ;
IN: unix.linux.fs
: MS_RDONLY 1 ; ! Mount read-only.
: MS_NOSUID 2 ; ! Ignore suid and sgid bits.
: MS_NODEV 4 ; ! Disallow access to device special files.
: MS_NOEXEC 8 ; ! Disallow program execution.
: MS_SYNCHRONOUS 16 ; ! Writes are synced at once.
: MS_REMOUNT 32 ; ! Alter flags of a mounted FS.
: MS_MANDLOCK 64 ; ! Allow mandatory locks on an FS.
: S_WRITE 128 ; ! Write on file/directory/symlink.
: S_APPEND 256 ; ! Append-only file.
: S_IMMUTABLE 512 ; ! Immutable file.
: MS_NOATIME 1024 ; ! Do not update access times.
: MS_NODIRATIME 2048 ; ! Do not update directory access times.
: MS_BIND 4096 ; ! Bind directory at different place.
FUNCTION: int mount
( char* special_file, char* dir, char* fstype, ulong options, void* data ) ;
! FUNCTION: int umount2 ( char* file, int flags ) ;
FUNCTION: int umount ( char* file ) ;

12
extra/unix/linux/swap/swap.factor Normal file
View File

@ -0,0 +1,12 @@
USING: alien.syntax ;
IN: unix.linux.swap
: SWAP_FLAG_PREFER HEX: 8000 ; ! Set if swap priority is specified.
: SWAP_FLAG_PRIO_MASK HEX: 7fff ;
: SWAP_FLAG_PRIO_SHIFT 0 ;
FUNCTION: int swapon ( char* path, int flags ) ;
FUNCTION: int swapoff ( char* path ) ;

22
extra/unix/process/process.factor
View File

@ -31,11 +31,23 @@ IN: unix.process
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! This is kludgy. We need a better implementation.
USING: kernel alien.c-types namespaces continuations threads assocs unix
combinators.cleave ;
USE: threads
SYMBOL: pid-wait
: wait-for-pid ( pid -- )
dup "int" <c-object> WNOHANG waitpid
0 = [ 100 sleep wait-for-pid ] [ drop ] if ;
! KEY | VALUE
! -----------
! pid | continuation
: init-pid-wait ( -- ) H{ } clone pid-wait set-global ;
: wait-for-pid ( pid -- status ) [ pid-wait get set-at stop ] curry callcc1 ;
: wait-loop ( -- )
-1 0 <int> tuck WNOHANG waitpid ! &status return
[ *int ] [ pid-wait get delete-at* drop ] bi* ! status ?
dup [ schedule-thread-with ] [ 2drop ] if
250 sleep wait-loop ;
: start-wait-loop ( -- ) init-pid-wait [ wait-loop ] in-thread ;

24
extra/unix/unix.factor
View File

@ -166,6 +166,10 @@ FUNCTION: time_t time ( time_t* t ) ;
FUNCTION: int unlink ( char* path ) ;
FUNCTION: int utimes ( char* path, timeval[2] times ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! wait and waitpid
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Flags for waitpid
: WNOHANG 1 ;
@ -176,7 +180,27 @@ FUNCTION: int utimes ( char* path, timeval[2] times ) ;
: WCONTINUED 8 ;
: WNOWAIT HEX: 1000000 ;
! Examining status
: WTERMSIG ( status -- value ) HEX: 7f bitand ;
: WIFEXITED ( status -- ? ) WTERMSIG zero? ;
: WEXITSTATUS ( status -- value ) HEX: ff00 bitand -8 shift ;
: WIFSIGNALED ( status -- ? ) HEX: 7f bitand 1+ -1 shift 0 > ;
: WCOREFLAG ( -- value ) HEX: 80 ;
: WCOREDUMP ( status -- ? ) WCOREFLAG bitand zero? not ;
: WIFSTOPPED ( status -- ? ) HEX: ff bitand HEX: 7f = ;
: WSTOPSIG ( status -- value ) WEXITSTATUS ;
FUNCTION: pid_t wait ( int* status ) ;
FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ;

2
extra/webapps/article-manager/furnace/article.furnace
View File

@ -1,4 +1,4 @@
<% USING: kernel io http.server namespaces sequences math html.elements random furnace webapps.article-manager webapps.article-manager.database ; %>
<% USING: kernel io http.server namespaces sequences math html.elements random furnace webapps.article-manager webapps.article-manager.database html.elements ; %>
<div id="banner"><h1><% "arg1" get second article-title write %></h1></div>
<% f "navigation" render-template %>
<div id="article">

2
extra/webapps/article-manager/furnace/tag.furnace
View File

@ -1,4 +1,4 @@
<% USING: kernel io http.server namespaces sequences math html furnace webapps.article-manager.database webapps.article-manager ; %>
<% USING: kernel io http.server namespaces sequences math html furnace webapps.article-manager.database webapps.article-manager html.elements ; %>
<div id="banner"><h1><% "arg1" get second tag-title write %></h1></div>
<% f "navigation" render-template %>

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.
!
USING: kernel furnace fjsc parser-combinators namespaces
lazy-lists io io.files furnace.validator sequences
http.client http.server http.server.responders
lazy-lists io io.files furnace.validator sequences
http.client http.server http.server.responders
webapps.file ;
IN: webapps.fjsc
@ -11,15 +11,15 @@ IN: webapps.fjsc
#! Compile the factor code as a string, outputting the http
#! response containing the javascript.
serving-text
'expression' parse car parse-result-parsed fjsc-compile
'expression' parse-1 fjsc-compile
write flush ;
! 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
! passing the parameter to it on the stack.
\ compile {
{ "code" v-required }
\ compile {
{ "code" v-required }
} define-action
: compile-url ( url -- )
@ -28,18 +28,18 @@ IN: webapps.fjsc
"http://" host rot 3append http-get 2nip compile "();" write flush ;
\ compile-url {
{ "url" v-required }
{ "url" v-required }
} define-action
: repl ( -- )
#! The main 'repl' page.
f "repl" "head" render-page* ;
! An action called 'repl'
! An action called 'repl'
\ repl { } define-action
: fjsc-web-app ( -- )
! Create the web app, providing access
! Create the web app, providing access
! under '/responder/fjsc' which calls the
! 'repl' action.
"fjsc" "repl" "extra/webapps/fjsc" web-app

3
extra/webapps/planet/planet.factor
View File

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

5
extra/windows/kernel32/kernel32.factor
View File

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

3
extra/x/x.factor
View File

@ -29,7 +29,8 @@ define-independent-class
<display> "create" !( name <display> -- display ) [
new-empty swap >>name
dup $name dup [ string>char-alien ] [ ] if XOpenDisplay >>ptr
dup $name dup [ string>char-alien ] [ ] if XOpenDisplay
dup [ >>ptr ] [ "XOpenDisplay error" throw ] if
dup $ptr XDefaultScreen >>default-screen
dup $ptr XDefaultRootWindow dupd <window> new >>default-root
dup $ptr over $default-screen XDefaultGC >>default-gc

2
extra/xml/data/data.factor
View File

@ -65,6 +65,8 @@ M: attrs set-at
M: attrs assoc-size length ;
M: attrs new-assoc drop V{ } new <attrs> ;
M: attrs assoc-find >r delegate r> assoc-find ;
M: attrs >alist delegate >alist ;
: >attrs ( assoc -- attrs )
V{ } assoc-clone-like

32
misc/factor.el
View File

@ -113,13 +113,6 @@
(defvar factor-binary "/scratch/repos/Factor/factor")
(defvar factor-image "/scratch/repos/Factor/factor.image")
(defun run-factor ()
(interactive)
(switch-to-buffer
(make-comint-in-buffer "factor" nil factor-binary nil
(concat "-i=" factor-image)
"-run=listener")))
(defun factor-telnet-to-port (port)
(interactive "nPort: ")
(switch-to-buffer
@ -166,9 +159,30 @@
(beginning-of-line)
(insert "! "))
(define-key factor-mode-map "\C-c\C-f" 'factor-run-file)
(define-key factor-mode-map "\C-c\C-r" 'factor-send-region)
(define-key factor-mode-map "\C-c\C-s" 'factor-see)
(define-key factor-mode-map "\C-ce" 'factor-edit)
(define-key factor-mode-map "\C-ce" 'factor-edit)
(define-key factor-mode-map "\C-c\C-h" 'factor-help)
(define-key factor-mode-map "\C-cc" 'comment-region)
(define-key factor-mode-map [return] 'newline-and-indent)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; factor-listener-mode
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-derived-mode factor-listener-mode comint-mode "Factor Listener")
(define-key factor-listener-mode-map [f8] 'factor-refresh-all)
(defun run-factor ()
(interactive)
(switch-to-buffer
(make-comint-in-buffer "factor" nil factor-binary nil
(concat "-i=" factor-image)
"-run=listener"))
(factor-listener-mode))
(defun factor-refresh-all ()
(interactive)
(comint-send-string "*factor*" "refresh-all\n"))

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

120
misc/install.sh
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

10
vm/Config.windows.nt.x86.32
View File

@ -1,7 +1,3 @@
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
include vm/Config.x86.32 vm/Config.windows
WINDRES=windres
include vm/Config.windows.nt
include vm/Config.x86.32

4
vm/Config.windows.nt.x86.64 Normal file
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

1
vm/debug.c
View File

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

6
vm/factor.c
View File

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

Some files were not shown because too many files have changed in this diff Show More