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

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

db4
Eduardo Cavazos 2007-12-10 01:56:28 -06:00
parent e7b8d380e3 9e93f6251e
commit b80eb94282
46 changed files with 742 additions and 437 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: io.files IN: io.files
USING: io.backend io.files.private io hashtables kernel math USING: io.backend io.files.private io hashtables kernel math
memory namespaces sequences strings arrays definitions system memory namespaces sequences strings assocs arrays definitions
combinators splitting ; system combinators splitting ;
HOOK: <file-reader> io-backend ( path -- stream ) HOOK: <file-reader> io-backend ( path -- stream )
@ -140,3 +140,20 @@ HOOK: binary-roots io-backend ( -- seq )
: find-binary ( str -- path/f ) : find-binary ( str -- path/f )
binary-roots swap find-file ; binary-roots swap find-file ;
<PRIVATE
: append-path ( path files -- paths )
[ path+ ] curry* map ;
: get-paths ( dir -- paths )
dup directory keys append-path ;
: (walk-dir) ( path -- )
dup directory? [
get-paths dup % [ (walk-dir) ] each
] [
drop
] if ;
PRIVATE>
: walk-dir ( path -- seq ) [ (walk-dir) ] { } make ;

3
extra/combinators/lib/lib.factor
View File

@ -70,9 +70,6 @@ MACRO: napply ( n -- )
MACRO: nfirst ( n -- ) MACRO: nfirst ( n -- )
[ [ swap nth ] curry [ keep ] curry ] map concat [ drop ] compose ; [ [ swap nth ] curry [ keep ] curry ] map concat [ drop ] compose ;
: seq>stack ( seq -- )
dup length nfirst ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: sigma ( seq quot -- n ) [ rot slip + ] curry 0 swap reduce ; : sigma ( seq quot -- n ) [ rot slip + ] curry 0 swap reduce ;

11
extra/editors/editpadpro/editpadpro.factor
View File

@ -1,8 +1,15 @@
USING: definitions kernel parser words sequences math.parser USING: definitions kernel parser words sequences math.parser
namespaces editors io.launcher ; namespaces editors io.launcher windows.shell32 io.files
io.paths strings ;
IN: editors.editpadpro IN: editors.editpadpro
: editpadpro-path
\ editpadpro-path get-global [
program-files "JGsoft" path+ walk-dir
[ >lower "editpadpro.exe" tail? ] find nip
] unless* ;
: editpadpro ( file line -- ) : editpadpro ( file line -- )
[ "editpadpro.exe /l" % # " \"" % % "\"" % ] "" make run-process ; [ editpadpro-path % " /l" % # " \"" % % "\"" % ] "" make run-detached ;
[ editpadpro ] edit-hook set-global [ editpadpro ] edit-hook set-global

13
extra/editors/editplus/editplus.factor Normal file → Executable file
View File

@ -1,12 +1,15 @@
USING: editors io.launcher math.parser namespaces ; USING: editors io.files io.launcher kernel math.parser
namespaces sequences windows.shell32 ;
IN: editors.editplus IN: editors.editplus
: editplus-path ( -- path )
\ editplus-path get-global [
program-files "\\EditPlus 2\\editplus.exe" append
] unless* ;
: editplus ( file line -- ) : editplus ( file line -- )
[ [
\ editplus get-global % " -cursor " % # " " % % editplus-path % " -cursor " % # " " % %
] "" make run-detached ; ] "" make run-detached ;
! Put in your .factor-boot-rc
! "c:\\Program Files\\EditPlus\\editplus.exe" \ editplus set-global
[ editplus ] edit-hook set-global [ editplus ] edit-hook set-global

10
extra/editors/emeditor/emeditor.factor Normal file → Executable file
View File

@ -1,9 +1,15 @@
USING: editors io.launcher kernel math.parser namespaces ; USING: editors hardware-info.windows io.files io.launcher
kernel math.parser namespaces sequences windows.shell32 ;
IN: editors.emeditor IN: editors.emeditor
: emeditor-path ( -- path )
\ emeditor-path get-global [
program-files "\\EmEditor\\EmEditor.exe" path+
] unless* ;
: emeditor ( file line -- ) : emeditor ( file line -- )
[ [
\ emeditor get-global % " /l " % # emeditor-path % " /l " % #
" " % "\"" % % "\"" % " " % "\"" % % "\"" %
] "" make run-detached ; ] "" make run-detached ;

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

@ -1,10 +1,18 @@
USING: kernel math math.parser namespaces editors.vim ; USING: io.backend io.files kernel math math.parser
namespaces editors.vim sequences system ;
IN: editors.gvim IN: editors.gvim
TUPLE: gvim ; TUPLE: gvim ;
HOOK: gvim-path io-backend ( -- path )
M: gvim vim-command ( file line -- string ) M: gvim vim-command ( file line -- string )
[ "\"" % vim-path get % "\" \"" % swap % "\" +" % # ] "" make ; [ "\"" % gvim-path % "\" \"" % swap % "\" +" % # ] "" make ;
t vim-detach set-global ! don't block the ui
T{ gvim } vim-editor set-global T{ gvim } vim-editor set-global
"gvim" vim-path set-global
USE-IF: unix? editors.gvim.unix
USE-IF: windows? editors.gvim.windows

7
extra/editors/gvim/unix/unix.factor Normal file
View File

@ -0,0 +1,7 @@
USING: editors.gvim io.unix.backend kernel namespaces ;
IN: editors.gvim.unix
M: unix-io gvim-path
\ gvim-path get-global [
"gvim"
] unless* ;

8
extra/editors/gvim/windows/windows.factor Normal file
View File

@ -0,0 +1,8 @@
USING: editors.gvim io.files io.windows kernel namespaces
sequences windows.shell32 ;
IN: editors.gvim.windows
M: windows-io gvim-path
\ gvim-path get-global [
program-files walk-dir [ "gvim.exe" tail? ] find nip
] unless* ;

14
extra/editors/notepadpp/notepadpp.factor
View File

@ -1,13 +1,15 @@
USING: editors io.launcher math.parser namespaces ; USING: editors io.files io.launcher kernel math.parser
namespaces windows.shell32 ;
IN: editors.notepadpp IN: editors.notepadpp
: notepadpp-path
\ notepadpp-path get-global [
program-files "notepad++\\notepad++.exe" path+
] unless* ;
: notepadpp ( file line -- ) : notepadpp ( file line -- )
[ [
\ notepadpp get-global % " -n" % # " " % % notepadpp-path % " -n" % # " " % %
] "" make run-detached ; ] "" 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 [ notepadpp ] edit-hook set-global

10
extra/editors/ted-notepad/ted-notepad.factor
View File

@ -1,9 +1,15 @@
USING: editors io.launcher kernel math.parser namespaces ; USING: editors io.files io.launcher kernel math.parser
namespaces sequences windows.shell32 ;
IN: editors.ted-notepad IN: editors.ted-notepad
: ted-notepad-path
\ ted-notepad-path get-global [
program-files "\\TED Notepad\\TedNPad.exe" path+
] unless* ;
: ted-notepad ( file line -- ) : ted-notepad ( file line -- )
[ [
\ ted-notepad get-global % " /l" % # ted-notepad-path % " /l" % #
" " % % " " % %
] "" make run-detached ; ] "" make run-detached ;

13
extra/editors/ultraedit/ultraedit.factor
View File

@ -1,12 +1,17 @@
USING: editors io.launcher kernel math.parser namespaces ; USING: editors io.files io.launcher kernel math.parser
namespaces sequences windows.shell32 ;
IN: editors.ultraedit IN: editors.ultraedit
: ultraedit-path ( -- path )
\ ultraedit-path get-global [
program-files
"\\IDM Computer Solutions\\UltraEdit-32\\uedit32.exe" path+
] unless* ;
: ultraedit ( file line -- ) : ultraedit ( file line -- )
[ [
\ ultraedit get-global % " " % swap % "/" % # "/1" % ultraedit-path % " " % swap % "/" % # "/1" %
] "" make run-detached ; ] "" make run-detached ;
! Put the path in your .factor-boot-rc
! "K:\\Program Files (x86)\\IDM Computer Solutions\\UltraEdit-32\\uedit32.exe" \ ultraedit set-global
[ ultraedit ] edit-hook set-global [ ultraedit ] edit-hook set-global

10
extra/editors/wordpad/wordpad.factor
View File

@ -2,12 +2,14 @@ USING: editors hardware-info.windows io.launcher kernel
math.parser namespaces sequences windows.shell32 ; math.parser namespaces sequences windows.shell32 ;
IN: editors.wordpad IN: editors.wordpad
: wordpad-path ( -- path )
\ wordpad-path get [
program-files "\\Windows NT\\Accessories\\wordpad.exe" append
] unless* ;
: wordpad ( file line -- ) : wordpad ( file line -- )
[ [
\ wordpad get-global % drop " " % "\"" % % "\"" % wordpad-path % drop " " % "\"" % % "\"" %
] "" make run-detached ; ] "" make run-detached ;
program-files "\\Windows NT\\Accessories\\wordpad.exe" append
\ wordpad set-global
[ wordpad ] edit-hook set-global [ wordpad ] edit-hook set-global

113
extra/faq/faq.factor Normal file
View File

@ -0,0 +1,113 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: xml kernel sequences xml.utilities combinators.lib
math xml.data arrays assocs xml.generator namespaces math.parser ;
IN: faq
: find-after ( seq quot -- elem after )
over >r find r> rot 1+ tail ; inline
: tag-named? ( tag name -- ? )
assure-name swap (get-tag) ;
! Questions
TUPLE: q/a question answer ;
C: <q/a> q/a
: li>q/a ( li -- q/a )
[ "br" tag-named? not ] subset
[ "strong" tag-named? ] find-after
>r tag-children r> <q/a> ;
: q/a>li ( q/a -- li )
[ q/a-question "strong" build-tag* f "br" build-tag* 2array ] keep
q/a-answer append "li" build-tag* ;
: xml>q/a ( xml -- q/a )
[ "question" tag-named tag-children ] keep
"answer" tag-named tag-children <q/a> ;
: q/a>xml ( q/a -- xml )
[ q/a-question "question" build-tag* ] keep
q/a-answer "answer" build-tag*
"\n" swap 3array "qa" build-tag* ;
! Lists of questions
TUPLE: question-list title seq ;
C: <question-list> question-list
: xml>question-list ( list -- question-list )
[ "title" swap at ] keep
tag-children [ tag? ] subset [ xml>q/a ] map
<question-list> ;
: question-list>xml ( question-list -- list )
[ question-list-seq [ q/a>xml "\n" swap 2array ]
map concat "list" build-tag* ] keep
question-list-title [ "title" pick set-at ] when* ;
: html>question-list ( h3 ol -- question-list )
>r [ children>string ] [ f ] if* r>
children-tags [ li>q/a ] map <question-list> ;
: question-list>h3 ( id question-list -- h3 )
question-list-title [
"h3" build-tag
swap number>string "id" pick set-at
] [ drop f ] if* ;
: question-list>html ( question-list start id -- h3/f ol )
-rot >r [ question-list>h3 ] keep
question-list-seq [ q/a>li ] map "ol" build-tag* r>
number>string "start" pick set-at
"margin-left: 5em" "style" pick set-at ;
! Overall everything
TUPLE: faq header lists ;
C: <faq> faq
: html>faq ( div -- faq )
unclip swap { "h3" "ol" } [ tags-named ] curry* map
first2 >r f add* r> [ html>question-list ] 2map <faq> ;
: header, ( faq -- )
dup faq-header ,
faq-lists first 1 -1 question-list>html nip , ;
: br, ( -- )
"br" contained, nl, ;
: toc-link, ( question-list number -- )
number>string "#" swap append "href" swap 2array 1array
"a" swap [ question-list-title , ] tag*, br, ;
: toc, ( faq -- )
"div" { { "style" "background-color: #eee; margin-left: 30%; margin-right: 30%; width: auto; padding: 5px; margin-top: 1em; margin-bottom: 1em" } } [
"strong" [ "The big questions" , ] tag, br,
faq-lists 1 tail dup length [ toc-link, ] 2each
] tag*, ;
: faq-sections, ( question-lists -- )
unclip question-list-seq length 1+ dupd
[ question-list-seq length + ] accumulate nip
0 -rot [ pick question-list>html [ , nl, ] 2apply 1+ ] 2each drop ;
: faq>html ( faq -- div )
"div" [
dup header,
dup toc,
faq-lists faq-sections,
] make-xml ;
: xml>faq ( xml -- faq )
[ "header" tag-named children>string ] keep
"list" tags-named [ xml>question-list ] map <faq> ;
: faq>xml ( faq -- xml )
"faq" [
"header" [ dup faq-header , ] tag,
faq-lists [ question-list>xml , nl, ] each
] make-xml ;
: read-write-faq ( xml-stream -- )
[ read-xml ] with-stream xml>faq faq>html write-xml ;

16
extra/id3/id3.factor
View File

@ -2,7 +2,9 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
! !
USING: arrays combinators io io.binary io.files io.utf16 kernel math math.parser namespaces sequences splitting strings assocs ; USING: arrays combinators io io.binary io.files io.paths
io.utf16 kernel math math.parser namespaces sequences
splitting strings assocs ;
IN: id3 IN: id3
@ -121,18 +123,6 @@ C: <extended-header> extended-header
: id3v2 ( filename -- tag/f ) : id3v2 ( filename -- tag/f )
<file-reader> [ read-tag ] with-stream ; <file-reader> [ read-tag ] with-stream ;
: append-path ( path files -- paths )
[ path+ ] curry* map ;
: get-paths ( dir -- paths )
dup directory keys append-path ;
: (walk-dir) ( path -- )
dup directory? [ get-paths dup % [ (walk-dir) ] each ] [ drop ] if ;
: walk-dir ( path -- seq )
[ (walk-dir) ] { } make ;
: file? ( path -- ? ) : file? ( path -- ? )
stat 3drop not ; stat 3drop not ;

24
extra/io/paths/paths.factor Normal file
View File

@ -0,0 +1,24 @@
USING: assocs io.files kernel namespaces sequences ;
IN: io.paths
: find-file ( seq str -- path/f )
[
[ path+ exists? ] curry find nip
] keep over [ path+ ] [ drop ] if ;
<PRIVATE
: append-path ( path files -- paths )
[ path+ ] curry* map ;
: get-paths ( dir -- paths )
dup directory keys append-path ;
: (walk-dir) ( path -- )
dup directory? [
get-paths dup % [ (walk-dir) ] each
] [
drop
] if ;
PRIVATE>
: walk-dir ( path -- seq ) [ (walk-dir) ] { } make ;

18
extra/io/unix/files/files.factor
View File

@ -38,21 +38,3 @@ M: unix-io make-directory ( path -- )
M: unix-io delete-directory ( path -- ) M: unix-io delete-directory ( path -- )
rmdir io-error ; rmdir io-error ;
M: unix-io binary-roots ( -- seq )
{
"/bin" "/sbin"
"/usr/bin" "/usr/sbin"
"/usr/local/bin" "/usr/local/sbin"
"/opt/local/bin" "/opt/local/sbin"
"~/bin"
} ;
M: unix-io library-roots ( -- seq )
{
"/lib"
"/usr/lib"
"/usr/local/lib"
"/opt/local/lib"
"/lib64"
} ;

5
extra/io/windows/nt/backend/backend.factor
View File

@ -27,7 +27,7 @@ M: windows-nt-io normalize-pathname ( string -- string )
{ [ dup ".\\" head? ] [ { [ dup ".\\" head? ] [
>r unicode-prefix cwd r> 1 tail 3append >r unicode-prefix cwd r> 1 tail 3append
] } ] }
! c:\\ ! c:\\foo
{ [ dup 1 tail ":" head? ] [ >r unicode-prefix r> append ] } { [ dup 1 tail ":" head? ] [ >r unicode-prefix r> append ] }
! \\\\?\\c:\\foo ! \\\\?\\c:\\foo
{ [ dup unicode-prefix head? ] [ ] } { [ dup unicode-prefix head? ] [ ] }
@ -38,7 +38,8 @@ M: windows-nt-io normalize-pathname ( string -- string )
dup first CHAR: \\ = [ CHAR: \\ , ] unless % dup first CHAR: \\ = [ CHAR: \\ , ] unless %
] "" make ] "" make
] } ] }
} cond [ "/\\." member? ] right-trim ; } cond [ "/\\." member? ] right-trim
dup peek CHAR: : = [ "\\" append ] when ;
SYMBOL: io-hash SYMBOL: io-hash

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

@ -11,16 +11,6 @@ TUPLE: windows-nt-io ;
TUPLE: windows-ce-io ; TUPLE: windows-ce-io ;
UNION: windows-io windows-nt-io windows-ce-io ; UNION: windows-io windows-nt-io windows-ce-io ;
M: windows-io library-roots ( -- seq )
[
windows ,
] { } make ;
M: windows-io binary-roots ( -- seq )
[
windows ,
] { } make ;
M: windows-io destruct-handle CloseHandle drop ; M: windows-io destruct-handle CloseHandle drop ;
M: windows-io destruct-socket closesocket drop ; M: windows-io destruct-socket closesocket drop ;

36
extra/parser-combinators/parser-combinators.factor
View File

@ -21,6 +21,9 @@ TUPLE: parse-result parsed unparsed ;
C: <parse-result> parse-result C: <parse-result> parse-result
: <parse-results> ( parsed unparsed -- list )
<parse-result> 1list ;
: parse-result-parsed-slice ( parse-result -- slice ) : parse-result-parsed-slice ( parse-result -- slice )
dup parse-result-parsed empty? [ dup parse-result-parsed empty? [
parse-result-unparsed 0 0 rot <slice> parse-result-unparsed 0 0 rot <slice>
@ -55,7 +58,7 @@ C: <token-parser> token-parser
M: token-parser parse ( input parser -- list ) M: token-parser parse ( input parser -- list )
dup token-parser-string swap token-parser-ignore-case? dup token-parser-string swap token-parser-ignore-case?
>r tuck r> ?string-head >r tuck r> ?string-head
[ <parse-result> 1list ] [ 2drop nil ] if ; [ <parse-results> ] [ 2drop nil ] if ;
: 1token ( n -- parser ) 1string token ; : 1token ( n -- parser ) 1string token ;
@ -70,11 +73,8 @@ M: satisfy-parser parse ( input parser -- list )
over empty? [ over empty? [
2drop nil 2drop nil
] [ ] [
satisfy-parser-quot >r unclip-slice dup r> call [ satisfy-parser-quot >r unclip-slice dup r> call
swap <parse-result> 1list [ swap <parse-results> ] [ 2drop nil ] if
] [
2drop nil
] if
] if ; ] if ;
LAZY: any-char-parser ( -- parser ) LAZY: any-char-parser ( -- parser )
@ -89,7 +89,7 @@ M: epsilon-parser parse ( input parser -- list )
#! does not consume any input and always returns #! does not consume any input and always returns
#! an empty list as the parse tree with the #! an empty list as the parse tree with the
#! unmodified input. #! unmodified input.
drop "" swap <parse-result> 1list ; drop "" swap <parse-results> ;
TUPLE: succeed-parser result ; TUPLE: succeed-parser result ;
@ -98,7 +98,7 @@ C: succeed succeed-parser ( result -- parser )
M: succeed-parser parse ( input parser -- list ) M: succeed-parser parse ( input parser -- list )
#! A parser that always returns 'result' as a #! A parser that always returns 'result' as a
#! successful parse with no input consumed. #! successful parse with no input consumed.
succeed-parser-result swap <parse-result> 1list ; succeed-parser-result swap <parse-results> ;
TUPLE: fail-parser ; TUPLE: fail-parser ;
@ -109,6 +109,24 @@ M: fail-parser parse ( input parser -- list )
#! an empty list of successes. #! an empty list of successes.
2drop nil ; 2drop nil ;
TUPLE: ensure-parser test ;
: ensure ( parser -- ensure )
ensure-parser construct-boa ;
M: ensure-parser parse ( input parser -- list )
2dup ensure-parser-test parse nil?
[ 2drop nil ] [ drop t swap <parse-results> ] if ;
TUPLE: ensure-not-parser test ;
: ensure-not ( parser -- ensure )
ensure-not-parser construct-boa ;
M: ensure-not-parser parse ( input parser -- list )
2dup ensure-not-parser-test parse nil?
[ drop t swap <parse-results> ] [ 2drop nil ] if ;
TUPLE: and-parser parsers ; TUPLE: and-parser parsers ;
: <&> ( parser1 parser2 -- parser ) : <&> ( parser1 parser2 -- parser )
@ -188,7 +206,7 @@ TUPLE: apply-parser p1 quot ;
C: <@ apply-parser ( parser quot -- parser ) C: <@ apply-parser ( parser quot -- parser )
M: apply-parser parse ( input parser -- result ) M: apply-parser parse ( input parser -- result )
#! Calls the parser on the input. For each successfull #! Calls the parser on the input. For each successful
#! parse the quot is call with the parse result on the stack. #! parse the quot is call with the parse result on the stack.
#! The result of that quotation then becomes the new parse result. #! The result of that quotation then becomes the new parse result.
#! This allows modification of parse tree results (like #! This allows modification of parse tree results (like

6
extra/random-tester/random/random.factor
View File

@ -18,13 +18,13 @@ IN: random-tester
: random-string : random-string
[ max-length random [ max-value random , ] times ] "" make ; [ max-length random [ max-value random , ] times ] "" make ;
SYMBOL: special-integers : special-integers ( -- seq ) \ special-integers get ;
[ { -1 0 1 } % most-negative-fixnum , most-positive-fixnum , first-bignum , ] [ { -1 0 1 } % most-negative-fixnum , most-positive-fixnum , first-bignum , ]
{ } make \ special-integers set-global { } make \ special-integers set-global
SYMBOL: special-floats : special-floats ( -- seq ) \ special-floats get ;
[ { 0.0 -0.0 } % e , pi , 1./0. , -1./0. , 0./0. , epsilon , epsilon neg , ] [ { 0.0 -0.0 } % e , pi , 1./0. , -1./0. , 0./0. , epsilon , epsilon neg , ]
{ } make \ special-floats set-global { } make \ special-floats set-global
SYMBOL: special-complexes : special-complexes ( -- seq ) \ special-complexes get ;
[ [
{ -1 0 1 C{ 0 1 } C{ 0 -1 } } % { -1 0 1 C{ 0 1 } C{ 0 -1 } } %
e , e neg , pi , pi neg , e , e neg , pi , pi neg ,

78
extra/random-tester/utils/utils.factor
View File

@ -1,7 +1,6 @@
USING: arrays assocs combinators.lib continuations kernel USING: arrays assocs combinators.lib continuations kernel
math math.functions memoize namespaces quotations random sequences math math.functions memoize namespaces quotations random sequences
sequences.private shuffle ; sequences.private shuffle ;
IN: random-tester.utils IN: random-tester.utils
: %chance ( n -- ? ) : %chance ( n -- ? )
@ -17,7 +16,7 @@ IN: random-tester.utils
: 80% ( -- ? ) 80 %chance ; : 80% ( -- ? ) 80 %chance ;
: 90% ( -- ? ) 90 %chance ; : 90% ( -- ? ) 90 %chance ;
: call-if ( quot ? -- ) [ call ] [ drop ] if ; inline : call-if ( quot ? -- ) swap when ; inline
: with-10% ( quot -- ) 10% call-if ; inline : with-10% ( quot -- ) 10% call-if ; inline
: with-20% ( quot -- ) 20% call-if ; inline : with-20% ( quot -- ) 20% call-if ; inline
@ -29,78 +28,7 @@ IN: random-tester.utils
: with-80% ( quot -- ) 80% call-if ; inline : with-80% ( quot -- ) 80% call-if ; inline
: with-90% ( quot -- ) 90% call-if ; inline : with-90% ( quot -- ) 90% call-if ; inline
: random-hash-key keys random ; : random-key keys random ;
: random-hash-value [ random-hash-key ] keep at ; : random-value [ random-key ] keep at ;
: do-one ( seq -- ) random call ; inline : do-one ( seq -- ) random call ; inline
TUPLE: p-list seq max count count-vec ;
: reset-array ( seq -- )
[ drop 0 ] over map-into ;
C: <p-list> p-list
: make-p-list ( seq n -- tuple )
>r dup length [ 1- ] keep r>
[ ^ 0 swap 2array ] keep
0 <array> <p-list> ;
: inc-seq ( seq max -- )
2dup [ < ] curry find-last over [
nipd 1+ 2over swap set-nth
1+ over length rot <slice> reset-array
] [
3drop reset-array
] if ;
: inc-count ( tuple -- )
[ p-list-count first2 >r 1+ r> 2array ] keep
set-p-list-count ;
: (get-permutation) ( seq index-seq -- newseq )
[ swap nth ] map-with ;
: get-permutation ( tuple -- seq )
[ p-list-seq ] keep p-list-count-vec (get-permutation) ;
: p-list-next ( tuple -- seq/f )
dup p-list-count first2 < [
[
[ get-permutation ] keep
[ p-list-count-vec ] keep p-list-max
inc-seq
] keep inc-count
] [
drop f
] if ;
: (permutations) ( tuple -- )
dup p-list-next [ , (permutations) ] [ drop ] if* ;
: permutations ( seq n -- seq )
make-p-list [ (permutations) ] { } make ;
: (each-permutation) ( tuple quot -- )
over p-list-next [
[ rot drop swap call ] 3keep
drop (each-permutation)
] [
2drop
] if* ; inline
: each-permutation ( seq n quot -- )
>r make-p-list r> (each-permutation) ;
: builder-permutations ( n -- seq )
{ [ compose ] [ swap curry ] } swap permutations
[ concat ] map ; foldable
: all-quot-permutations ( seq -- newseq )
dup length 1- builder-permutations
swap [ 1quotation ] map dup length permutations
[ swap [ >r seq>stack r> call ] curry* map ] curry* map ;
! clear { map sq 10 } all-quot-permutations [ [ [ [ [ call ] keep datastack length 2 = [ . .s nl ] when ] catch ] in-thread drop ] each ] each
! clear { map sq sq 10 } all-quot-permutations [ [ [ [ [ call ] keep datastack length 2 = [ . .s nl ] when ] catch ] in-thread drop ] each ] each

23
extra/regexp/regexp-tests.factor
View File

@ -199,3 +199,26 @@ IN: regexp-tests
"(0[lL]?|[1-9]\\d{0,9}(\\d{0,9}[lL])?|0[xX]\\p{XDigit}{1,8}(\\p{XDigit}{0,8}[lL])?|0[0-7]{1,11}([0-7]{0,11}[lL])?|([0-9]+\\.[0-9]*|\\.[0-9]+)([eE][+-]?[0-9]+)?[fFdD]?|[0-9]+([eE][+-]?[0-9]+[fFdD]?|([eE][+-]?[0-9]+)?[fFdD]))" "(0[lL]?|[1-9]\\d{0,9}(\\d{0,9}[lL])?|0[xX]\\p{XDigit}{1,8}(\\p{XDigit}{0,8}[lL])?|0[0-7]{1,11}([0-7]{0,11}[lL])?|([0-9]+\\.[0-9]*|\\.[0-9]+)([eE][+-]?[0-9]+)?[fFdD]?|[0-9]+([eE][+-]?[0-9]+[fFdD]?|([eE][+-]?[0-9]+)?[fFdD]))"
f <regexp> drop f <regexp> drop
] unit-test ] unit-test
[ t ] [ "fxxbar" "(?!foo).{3}bar" f <regexp> matches? ] unit-test
[ f ] [ "foobar" "(?!foo).{3}bar" f <regexp> matches? ] unit-test
[ 3 ] [ "foobar" "foo(?=bar)" f <regexp> match-head ] unit-test
[ f ] [ "foobxr" "foo(?=bar)" f <regexp> match-head ] unit-test
[ f ] [ "foobxr" "foo\\z" f <regexp> match-head ] unit-test
[ 3 ] [ "foo" "foo\\z" f <regexp> match-head ] unit-test
[ 3 ] [ "foo bar" "foo\\b" f <regexp> match-head ] unit-test
[ f ] [ "fooxbar" "foo\\b" f <regexp> matches? ] unit-test
[ t ] [ "foo" "foo\\b" f <regexp> matches? ] unit-test
[ t ] [ "foo bar" "foo\\b bar" f <regexp> matches? ] unit-test
[ f ] [ "fooxbar" "foo\\bxbar" f <regexp> matches? ] unit-test
[ f ] [ "foo" "foo\\bbar" f <regexp> matches? ] unit-test
[ f ] [ "foo bar" "foo\\B" f <regexp> matches? ] unit-test
[ 3 ] [ "fooxbar" "foo\\B" f <regexp> match-head ] unit-test
[ t ] [ "foo" "foo\\B" f <regexp> matches? ] unit-test
[ f ] [ "foo bar" "foo\\B bar" f <regexp> matches? ] unit-test
[ t ] [ "fooxbar" "foo\\Bxbar" f <regexp> matches? ] unit-test
[ f ] [ "foo" "foo\\Bbar" f <regexp> matches? ] unit-test

35
extra/regexp/regexp.factor
View File

@ -1,7 +1,7 @@
USING: arrays combinators kernel lazy-lists math math.parser USING: arrays combinators kernel lazy-lists math math.parser
namespaces parser parser-combinators parser-combinators.simple namespaces parser parser-combinators parser-combinators.simple
promises quotations sequences combinators.lib strings promises quotations sequences combinators.lib strings
assocs prettyprint.backend ; assocs prettyprint.backend memoize ;
USE: io USE: io
IN: regexp IN: regexp
@ -148,10 +148,22 @@ TUPLE: group-result str ;
C: <group-result> group-result C: <group-result> group-result
: 'non-capturing-group' ( -- parser ) : 'non-capturing-group' ( -- parser )
'regexp' "(?:" ")" surrounded-by ; "?:" token 'regexp' &> ;
: 'positive-lookahead-group' ( -- parser )
"?=" token 'regexp' &> [ ensure ] <@ ;
: 'negative-lookahead-group' ( -- parser )
"?!" token 'regexp' &> [ ensure-not ] <@ ;
: 'simple-group' ( -- parser )
'regexp' [ [ <group-result> ] <@ ] <@ ;
: 'group' ( -- parser ) : 'group' ( -- parser )
'regexp' [ [ <group-result> ] <@ ] <@ 'non-capturing-group'
'positive-lookahead-group'
'negative-lookahead-group'
'simple-group' <|> <|> <|>
"(" ")" surrounded-by ; "(" ")" surrounded-by ;
: 'range' ( -- parser ) : 'range' ( -- parser )
@ -181,12 +193,21 @@ C: <group-result> group-result
[ ignore-case? get <token-parser> ] <@ [ ignore-case? get <token-parser> ] <@
"\\Q" "\\E" surrounded-by ; "\\Q" "\\E" surrounded-by ;
: 'break' ( quot -- parser )
satisfy ensure epsilon just <|> ;
: 'break-escape' ( -- parser )
"$" token [ "\r\n" member? ] 'break' <@literal
"\\b" token [ blank? ] 'break' <@literal <|>
"\\B" token [ blank? not ] 'break' <@literal <|>
"\\z" token epsilon just <@literal <|> ;
: 'simple' ( -- parser ) : 'simple' ( -- parser )
'escaped-seq' 'escaped-seq'
'non-capturing-group' <|> 'break-escape' <|>
'group' <|> 'group' <|>
'char' <|> 'character-class' <|>
'character-class' <|> ; 'char' <|> ;
: 'exactly-n' ( -- parser ) : 'exactly-n' ( -- parser )
'integer' [ exactly-n ] <@delay ; 'integer' [ exactly-n ] <@delay ;
@ -226,7 +247,7 @@ C: <group-result> group-result
: 'dummy' ( -- parser ) : 'dummy' ( -- parser )
epsilon [ ] <@literal ; epsilon [ ] <@literal ;
: 'term' ( -- parser ) MEMO: 'term' ( -- parser )
'simple' 'simple'
'repetition' 'interval' 'dummy' <|> <|> <&> [ first2 call ] <@ 'repetition' 'interval' 'dummy' <|> <|> <&> [ first2 call ] <@
<!+> [ <and-parser> ] <@ ; <!+> [ <and-parser> ] <@ ;

2
extra/shuffle/shuffle.factor
View File

@ -29,4 +29,6 @@ MACRO: ntuck ( n -- ) 2 + [ dup , -nrot ] bake ;
: 4dup ( a b c d -- a b c d a b c d ) 4 ndup ; inline : 4dup ( a b c d -- a b c d a b c d ) 4 ndup ; inline
: 4drop ( a b c d -- ) 3drop drop ; inline
: tuckd ( x y z -- z x y z ) 2 ntuck ; inline : tuckd ( x y z -- z x y z ) 2 ntuck ; inline

1
extra/sqlite/sqlite-docs.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2006 Chris Double. ! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: help sqlite help.syntax help.markup ; USING: help sqlite help.syntax help.markup ;
IN: sqlite
HELP: sqlite-open HELP: sqlite-open
{ $values { "filename" "path to sqlite database" } { $values { "filename" "path to sqlite database" }

7
extra/sqlite/tuple-db/tuple-db-docs.factor
View File

@ -1,10 +1,11 @@
! Copyright (C) 2006 Chris Double. ! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: help sqlite sqlite.tuple-db help.syntax help.markup ; USING: help sqlite sqlite.tuple-db help.syntax help.markup ;
IN: sqlite.tuple-db
ARTICLE: { "sqlite" "tuple-db-loading" } "Loading" ARTICLE: { "sqlite" "tuple-db-loading" } "Loading"
"The quickest way to get up and running with this library is to load it as a module:" "The quickest way to get up and running with this library is to use the vocabulary:"
{ $code "\"libs/sqlite\" require\nUSE: sqlite\nUSE: tuple-db\n" } { $code "USING: sqlite sqlite.tuple-db ;\n" }
"Some simple tests can be run to check that everything is working ok:" "Some simple tests can be run to check that everything is working ok:"
{ $code "\"libs/sqlite\" test-module" } ; { $code "\"libs/sqlite\" test-module" } ;
@ -126,3 +127,5 @@ HELP: delete-tuple
} }
{ $description "Delete this tuple instance from the database. The tuple must have previously been obtained from the database, or inserted into it. It must have a delegate of 'persistent' with the key field set (which is done by the find and insert operations)." } { $description "Delete this tuple instance from the database. The tuple must have previously been obtained from the database, or inserted into it. It must have a delegate of 'persistent' with the key field set (which is done by the find and insert operations)." }
{ $see-also { "sqlite" "tuple-db" } insert-tuple update-tuple find-tuples delete-tuple save-tuple } ; { $see-also { "sqlite" "tuple-db" } insert-tuple update-tuple find-tuples delete-tuple save-tuple } ;
ABOUT: { "sqlite" "tuple-db" }

7
extra/store/store.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2007 Doug Coleman. ! Copyright (C) 2006, 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs io io.files kernel namespaces serialize ; USING: assocs io io.files kernel namespaces serialize init ;
IN: store IN: store
TUPLE: store path data ; TUPLE: store path data ;
@ -30,3 +30,8 @@ C: <store> store
] [ ] [
drop >r 2dup set-global r> set-at drop >r 2dup set-global r> set-at
] if ; ] if ;
: define-store ( path id -- )
over >r
[ >r resource-path load-store r> set-global ] 2curry
r> add-init-hook ;

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

@ -67,11 +67,11 @@ M: workspace model-changed
: com-profiler profiler-gadget select-tool ; : com-profiler profiler-gadget select-tool ;
workspace "tool-switching" f { workspace "tool-switching" f {
{ T{ key-down f { C+ } "1" } com-listener } { T{ key-down f { A+ } "1" } com-listener }
{ T{ key-down f { C+ } "2" } com-browser } { T{ key-down f { A+ } "2" } com-browser }
{ T{ key-down f { C+ } "3" } com-inspector } { T{ key-down f { A+ } "3" } com-inspector }
{ T{ key-down f { C+ } "4" } com-walker } { T{ key-down f { A+ } "4" } com-walker }
{ T{ key-down f { C+ } "5" } com-profiler } { T{ key-down f { A+ } "5" } com-profiler }
} define-command-map } define-command-map
\ workspace-window \ workspace-window

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

@ -210,6 +210,9 @@ SYMBOL: hWnd
hWnd get window-focus send-gesture hWnd get window-focus send-gesture
drop ; drop ;
: handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
dup alpha? [ 4drop 0 ] [ DefWindowProc ] if ;
: cleanup-window ( handle -- ) : cleanup-window ( handle -- )
dup win-title [ free ] when* dup win-title [ free ] when*
dup win-hRC wglDeleteContext win32-error=0/f dup win-hRC wglDeleteContext win32-error=0/f
@ -295,17 +298,17 @@ M: windows-ui-backend (close-window)
: handle-wm-cancelmode ( hWnd uMsg wParam lParam -- ) : handle-wm-cancelmode ( hWnd uMsg wParam lParam -- )
#! message sent if windows needs application to stop dragging #! message sent if windows needs application to stop dragging
3drop drop release-capture ; 4drop release-capture ;
: handle-wm-mouseleave ( hWnd uMsg wParam lParam -- ) : handle-wm-mouseleave ( hWnd uMsg wParam lParam -- )
#! message sent if mouse leaves main application #! message sent if mouse leaves main application
3drop drop forget-rollover ; 4drop forget-rollover ;
! return 0 if you handle the message, else just let DefWindowProc return its val ! return 0 if you handle the message, else just let DefWindowProc return its val
: ui-wndproc ( -- object ) : ui-wndproc ( -- object )
"uint" { "void*" "uint" "long" "long" } "stdcall" [ "uint" { "void*" "uint" "long" "long" } "stdcall" [
[ [
pick pick ! global [ dup windows-message-name . ] bind
{ {
{ [ dup WM_CLOSE = ] [ drop handle-wm-close 0 ] } { [ dup WM_CLOSE = ] [ drop handle-wm-close 0 ] }
{ [ dup WM_PAINT = ] { [ dup WM_PAINT = ]
@ -320,6 +323,7 @@ M: windows-ui-backend (close-window)
{ [ dup WM_KEYUP = over WM_SYSKEYUP = or ] { [ dup WM_KEYUP = over WM_SYSKEYUP = or ]
[ drop 4dup handle-wm-keyup DefWindowProc ] } [ drop 4dup handle-wm-keyup DefWindowProc ] }
{ [ dup WM_SYSCOMMAND = ] [ drop handle-wm-syscommand ] }
{ [ dup WM_SETFOCUS = ] [ drop handle-wm-set-focus 0 ] } { [ dup WM_SETFOCUS = ] [ drop handle-wm-set-focus 0 ] }
{ [ dup WM_KILLFOCUS = ] [ drop handle-wm-kill-focus 0 ] } { [ dup WM_KILLFOCUS = ] [ drop handle-wm-kill-focus 0 ] }

2
extra/webapps/pastebin/new-paste.furnace
View File

@ -24,10 +24,12 @@
<td><% "modes" render-template %></td> <td><% "modes" render-template %></td>
</tr> </tr>
<!--
<tr> <tr>
<th align="right">Channel:</th> <th align="right">Channel:</th>
<td><input type="TEXT" name="channel" value="#concatenative" /></td> <td><input type="TEXT" name="channel" value="#concatenative" /></td>
</tr> </tr>
-->
<tr> <tr>
<th align="right" valign="top">Content:</th> <th align="right" valign="top">Content:</th>

8
extra/webapps/pastebin/paste-summary.furnace
View File

@ -4,13 +4,9 @@ furnace webapps.pastebin calendar sequences ; %>
<tr> <tr>
<td> <td>
<a href="<% model get paste-link write %>"> <a href="<% model get paste-link write %>">
<% <% "summary" get write %>
"summary" get
dup empty? [ drop "- no title -" ] when
write
%>
</a> </a>
</td> </td>
<td><% "author" get write %></td> <td><% "author" get write %></td>
<td><% "date" get timestamp>string print %></td> <td><% "date" get timestamp>string write %></td>
</tr> </tr>

21
extra/webapps/pastebin/pastebin.factor
View File

@ -8,6 +8,12 @@ TUPLE: pastebin pastes ;
: <pastebin> ( -- pastebin ) : <pastebin> ( -- pastebin )
V{ } clone pastebin construct-boa ; V{ } clone pastebin construct-boa ;
! Persistence
SYMBOL: store
"pastebin.store" store define-store
<pastebin> pastebin store get store-variable
: save-pastebin-store ( -- ) store get-global save-store ;
TUPLE: paste TUPLE: paste
summary author channel mode contents date summary author channel mode contents date
annotations n ; annotations n ;
@ -19,12 +25,6 @@ TUPLE: annotation summary author mode contents ;
C: <annotation> annotation C: <annotation> annotation
SYMBOL: store
"pastebin.store" resource-path load-store store set-global
<pastebin> \ pastebin store get store-variable
: get-paste ( n -- paste ) : get-paste ( n -- paste )
pastebin get pastebin-pastes nth ; pastebin get pastebin-pastes nth ;
@ -71,9 +71,6 @@ SYMBOL: store
\ feed.xml { } define-action \ feed.xml { } define-action
: save-pastebin-store ( -- )
store get-global save-store ;
: add-paste ( paste pastebin -- ) : add-paste ( paste pastebin -- )
>r now over set-paste-date r> >r now over set-paste-date r>
pastebin-pastes 2dup length swap set-paste-n push ; pastebin-pastes 2dup length swap set-paste-n push ;
@ -85,8 +82,8 @@ SYMBOL: store
] keep paste-link permanent-redirect ; ] keep paste-link permanent-redirect ;
\ submit-paste { \ submit-paste {
{ "summary" v-required } { "summary" "- no summary -" v-default }
{ "author" v-required } { "author" "- no author -" v-default }
{ "channel" "#concatenative" v-default } { "channel" "#concatenative" v-default }
{ "mode" "factor" v-default } { "mode" "factor" v-default }
{ "contents" v-required } { "contents" v-required }
@ -99,7 +96,7 @@ SYMBOL: store
\ annotate-paste { \ annotate-paste {
{ "n" v-required v-number } { "n" v-required v-number }
{ "summary" v-required } { "summary" "- no summary -" v-default }
{ "author" v-required } { "author" v-required }
{ "mode" "factor" v-default } { "mode" "factor" v-default }
{ "contents" v-required } { "contents" v-required }

2
extra/webapps/pastebin/show-paste.furnace
View File

@ -7,7 +7,7 @@
<table> <table>
<tr><th>Paste by:</th><td><% "author" get write %></td></tr> <tr><th>Paste by:</th><td><% "author" get write %></td></tr>
<tr><th>Channel:</th><td><% "channel" get write %></td></tr> <!-- <tr><th>Channel:</th><td><% "channel" get write %></td></tr> -->
<tr><th>Created:</th><td><% "date" get timestamp>string write %></td></tr> <tr><th>Created:</th><td><% "date" get timestamp>string write %></td></tr>
<tr><th>File type:</th><td><% "mode" get write %></td></tr> <tr><th>File type:</th><td><% "mode" get write %></td></tr>
</table> </table>

4
extra/windows/messages/messages.factor
View File

@ -13,7 +13,7 @@ SYMBOL: windows-messages
word [ word-name ] keep execute maybe-create-windows-messages word [ word-name ] keep execute maybe-create-windows-messages
windows-messages get set-at ; parsing windows-messages get set-at ; parsing
: get-windows-message-name ( n -- name ) : windows-message-name ( n -- name )
windows-messages get at* [ drop "unknown message" ] unless ; windows-messages get at* [ drop "unknown message" ] unless ;
: WM_NULL HEX: 0000 ; inline add-windows-message : WM_NULL HEX: 0000 ; inline add-windows-message
@ -107,6 +107,8 @@ SYMBOL: windows-messages
: WM_NCXBUTTONDOWN HEX: 00AB ; inline add-windows-message : WM_NCXBUTTONDOWN HEX: 00AB ; inline add-windows-message
: WM_NCXBUTTONUP HEX: 00AC ; inline add-windows-message : WM_NCXBUTTONUP HEX: 00AC ; inline add-windows-message
: WM_NCXBUTTONDBLCLK HEX: 00AD ; inline add-windows-message : WM_NCXBUTTONDBLCLK HEX: 00AD ; inline add-windows-message
: WM_NCUAHDRAWCAPTION HEX: 00AE ; inline add-windows-message ! undocumented
: WM_NCUAHDRAWFRAME HEX: 00AF ; inline add-windows-message ! undocumented
: WM_INPUT HEX: 00FF ; inline add-windows-message : WM_INPUT HEX: 00FF ; inline add-windows-message
: WM_KEYFIRST HEX: 0100 ; inline add-windows-message : WM_KEYFIRST HEX: 0100 ; inline add-windows-message
: WM_KEYDOWN HEX: 0100 ; inline add-windows-message : WM_KEYDOWN HEX: 0100 ; inline add-windows-message

6
extra/windows/types/types.factor
View File

@ -333,4 +333,8 @@ C-STRUCT: LVFINDINFO
{ "POINT" "pt" } { "POINT" "pt" }
{ "uint" "vkDirection" } ; { "uint" "vkDirection" } ;
C-STRUCT: ACCEL
{ "BYTE" "fVirt" }
{ "WORD" "key" }
{ "WORD" "cmd" } ;
TYPEDEF: ACCEL* LPACCEL

361
extra/windows/user32/user32.factor
View File

@ -5,43 +5,43 @@ windows.types shuffle ;
IN: windows.user32 IN: windows.user32
! HKL for ActivateKeyboardLayout ! HKL for ActivateKeyboardLayout
: HKL_PREV 0 ; : HKL_PREV 0 ; inline
: HKL_NEXT 1 ; : HKL_NEXT 1 ; inline
: CW_USEDEFAULT HEX: 80000000 ; : CW_USEDEFAULT HEX: 80000000 ; inline
: WS_OVERLAPPED HEX: 00000000 ; : WS_OVERLAPPED HEX: 00000000 ; inline
: WS_POPUP HEX: 80000000 ; : WS_POPUP HEX: 80000000 ; inline
: WS_CHILD HEX: 40000000 ; : WS_CHILD HEX: 40000000 ; inline
: WS_MINIMIZE HEX: 20000000 ; : WS_MINIMIZE HEX: 20000000 ; inline
: WS_VISIBLE HEX: 10000000 ; : WS_VISIBLE HEX: 10000000 ; inline
: WS_DISABLED HEX: 08000000 ; : WS_DISABLED HEX: 08000000 ; inline
: WS_CLIPSIBLINGS HEX: 04000000 ; : WS_CLIPSIBLINGS HEX: 04000000 ; inline
: WS_CLIPCHILDREN HEX: 02000000 ; : WS_CLIPCHILDREN HEX: 02000000 ; inline
: WS_MAXIMIZE HEX: 01000000 ; : WS_MAXIMIZE HEX: 01000000 ; inline
: WS_CAPTION HEX: 00C00000 ; ! /* WS_BORDER | WS_DLGFRAME */ : WS_CAPTION HEX: 00C00000 ; inline
: WS_BORDER HEX: 00800000 ; : WS_BORDER HEX: 00800000 ; inline
: WS_DLGFRAME HEX: 00400000 ; : WS_DLGFRAME HEX: 00400000 ; inline
: WS_VSCROLL HEX: 00200000 ; : WS_VSCROLL HEX: 00200000 ; inline
: WS_HSCROLL HEX: 00100000 ; : WS_HSCROLL HEX: 00100000 ; inline
: WS_SYSMENU HEX: 00080000 ; : WS_SYSMENU HEX: 00080000 ; inline
: WS_THICKFRAME HEX: 00040000 ; : WS_THICKFRAME HEX: 00040000 ; inline
: WS_GROUP HEX: 00020000 ; : WS_GROUP HEX: 00020000 ; inline
: WS_TABSTOP HEX: 00010000 ; : WS_TABSTOP HEX: 00010000 ; inline
: WS_MINIMIZEBOX HEX: 00020000 ; : WS_MINIMIZEBOX HEX: 00020000 ; inline
: WS_MAXIMIZEBOX HEX: 00010000 ; : WS_MAXIMIZEBOX HEX: 00010000 ; inline
! Common window styles ! Common window styles
: WS_OVERLAPPEDWINDOW WS_OVERLAPPED WS_CAPTION WS_SYSMENU WS_THICKFRAME WS_MINIMIZEBOX WS_MAXIMIZEBOX bitor bitor bitor bitor bitor ; : WS_OVERLAPPEDWINDOW WS_OVERLAPPED WS_CAPTION WS_SYSMENU WS_THICKFRAME WS_MINIMIZEBOX WS_MAXIMIZEBOX bitor bitor bitor bitor bitor ; foldable inline
: WS_POPUPWINDOW WS_POPUP WS_BORDER WS_SYSMENU bitor bitor ; : WS_POPUPWINDOW WS_POPUP WS_BORDER WS_SYSMENU bitor bitor ; foldable inline
: WS_CHILDWINDOW WS_CHILD ; : WS_CHILDWINDOW WS_CHILD ; inline
: WS_TILED WS_OVERLAPPED ; : WS_TILED WS_OVERLAPPED ; inline
: WS_ICONIC WS_MINIMIZE ; : WS_ICONIC WS_MINIMIZE ; inline
: WS_SIZEBOX WS_THICKFRAME ; : WS_SIZEBOX WS_THICKFRAME ; inline
: WS_TILEDWINDOW WS_OVERLAPPEDWINDOW ; : WS_TILEDWINDOW WS_OVERLAPPEDWINDOW ; inline
! Extended window styles ! Extended window styles
@ -65,72 +65,74 @@ IN: windows.user32
: WS_EX_CONTROLPARENT HEX: 00010000 ; inline : WS_EX_CONTROLPARENT HEX: 00010000 ; inline
: WS_EX_STATICEDGE HEX: 00020000 ; inline : WS_EX_STATICEDGE HEX: 00020000 ; inline
: WS_EX_APPWINDOW HEX: 00040000 ; inline : WS_EX_APPWINDOW HEX: 00040000 ; inline
: WS_EX_OVERLAPPEDWINDOW WS_EX_WINDOWEDGE WS_EX_CLIENTEDGE bitor ; inline : WS_EX_OVERLAPPEDWINDOW ( -- n )
: WS_EX_PALETTEWINDOW WS_EX_WINDOWEDGE WS_EX_CLIENTEDGE bitor ; foldable inline
WS_EX_WINDOWEDGE WS_EX_TOOLWINDOW bitor WS_EX_TOPMOST bitor ; inline : WS_EX_PALETTEWINDOW ( -- n )
WS_EX_WINDOWEDGE WS_EX_TOOLWINDOW bitor
WS_EX_TOPMOST bitor ; foldable inline
: CS_VREDRAW HEX: 0001 ; : CS_VREDRAW HEX: 0001 ; inline
: CS_HREDRAW HEX: 0002 ; : CS_HREDRAW HEX: 0002 ; inline
: CS_DBLCLKS HEX: 0008 ; : CS_DBLCLKS HEX: 0008 ; inline
: CS_OWNDC HEX: 0020 ; : CS_OWNDC HEX: 0020 ; inline
: CS_CLASSDC HEX: 0040 ; : CS_CLASSDC HEX: 0040 ; inline
: CS_PARENTDC HEX: 0080 ; : CS_PARENTDC HEX: 0080 ; inline
: CS_NOCLOSE HEX: 0200 ; : CS_NOCLOSE HEX: 0200 ; inline
: CS_SAVEBITS HEX: 0800 ; : CS_SAVEBITS HEX: 0800 ; inline
: CS_BYTEALIGNCLIENT HEX: 1000 ; : CS_BYTEALIGNCLIENT HEX: 1000 ; inline
: CS_BYTEALIGNWINDOW HEX: 2000 ; : CS_BYTEALIGNWINDOW HEX: 2000 ; inline
: CS_GLOBALCLASS HEX: 4000 ; : CS_GLOBALCLASS HEX: 4000 ; inline
: COLOR_SCROLLBAR 0 ; : COLOR_SCROLLBAR 0 ; inline
: COLOR_BACKGROUND 1 ; : COLOR_BACKGROUND 1 ; inline
: COLOR_ACTIVECAPTION 2 ; : COLOR_ACTIVECAPTION 2 ; inline
: COLOR_INACTIVECAPTION 3 ; : COLOR_INACTIVECAPTION 3 ; inline
: COLOR_MENU 4 ; : COLOR_MENU 4 ; inline
: COLOR_WINDOW 5 ; : COLOR_WINDOW 5 ; inline
: COLOR_WINDOWFRAME 6 ; : COLOR_WINDOWFRAME 6 ; inline
: COLOR_MENUTEXT 7 ; : COLOR_MENUTEXT 7 ; inline
: COLOR_WINDOWTEXT 8 ; : COLOR_WINDOWTEXT 8 ; inline
: COLOR_CAPTIONTEXT 9 ; : COLOR_CAPTIONTEXT 9 ; inline
: COLOR_ACTIVEBORDER 10 ; : COLOR_ACTIVEBORDER 10 ; inline
: COLOR_INACTIVEBORDER 11 ; : COLOR_INACTIVEBORDER 11 ; inline
: COLOR_APPWORKSPACE 12 ; : COLOR_APPWORKSPACE 12 ; inline
: COLOR_HIGHLIGHT 13 ; : COLOR_HIGHLIGHT 13 ; inline
: COLOR_HIGHLIGHTTEXT 14 ; : COLOR_HIGHLIGHTTEXT 14 ; inline
: COLOR_BTNFACE 15 ; : COLOR_BTNFACE 15 ; inline
: COLOR_BTNSHADOW 16 ; : COLOR_BTNSHADOW 16 ; inline
: COLOR_GRAYTEXT 17 ; : COLOR_GRAYTEXT 17 ; inline
: COLOR_BTNTEXT 18 ; : COLOR_BTNTEXT 18 ; inline
: COLOR_INACTIVECAPTIONTEXT 19 ; : COLOR_INACTIVECAPTIONTEXT 19 ; inline
: COLOR_BTNHIGHLIGHT 20 ; : COLOR_BTNHIGHLIGHT 20 ; inline
: IDI_APPLICATION 32512 ; : IDI_APPLICATION 32512 ; inline
: IDI_HAND 32513 ; : IDI_HAND 32513 ; inline
: IDI_QUESTION 32514 ; : IDI_QUESTION 32514 ; inline
: IDI_EXCLAMATION 32515 ; : IDI_EXCLAMATION 32515 ; inline
: IDI_ASTERISK 32516 ; : IDI_ASTERISK 32516 ; inline
: IDI_WINLOGO 32517 ; : IDI_WINLOGO 32517 ; inline
! ShowWindow() Commands ! ShowWindow() Commands
: SW_HIDE 0 ; : SW_HIDE 0 ; inline
: SW_SHOWNORMAL 1 ; : SW_SHOWNORMAL 1 ; inline
: SW_NORMAL 1 ; : SW_NORMAL 1 ; inline
: SW_SHOWMINIMIZED 2 ; : SW_SHOWMINIMIZED 2 ; inline
: SW_SHOWMAXIMIZED 3 ; : SW_SHOWMAXIMIZED 3 ; inline
: SW_MAXIMIZE 3 ; : SW_MAXIMIZE 3 ; inline
: SW_SHOWNOACTIVATE 4 ; : SW_SHOWNOACTIVATE 4 ; inline
: SW_SHOW 5 ; : SW_SHOW 5 ; inline
: SW_MINIMIZE 6 ; : SW_MINIMIZE 6 ; inline
: SW_SHOWMINNOACTIVE 7 ; : SW_SHOWMINNOACTIVE 7 ; inline
: SW_SHOWNA 8 ; : SW_SHOWNA 8 ; inline
: SW_RESTORE 9 ; : SW_RESTORE 9 ; inline
: SW_SHOWDEFAULT 10 ; : SW_SHOWDEFAULT 10 ; inline
: SW_FORCEMINIMIZE 11 ; : SW_FORCEMINIMIZE 11 ; inline
: SW_MAX 11 ; : SW_MAX 11 ; inline
! PeekMessage ! PeekMessage
: PM_NOREMOVE 0 ; : PM_NOREMOVE 0 ; inline
: PM_REMOVE 1 ; : PM_REMOVE 1 ; inline
: PM_NOYIELD 2 ; : PM_NOYIELD 2 ; inline
! : PM_QS_INPUT (QS_INPUT << 16) ; ! : PM_QS_INPUT (QS_INPUT << 16) ;
! : PM_QS_POSTMESSAGE ((QS_POSTMESSAGE | QS_HOTKEY | QS_TIMER) << 16) ; ! : PM_QS_POSTMESSAGE ((QS_POSTMESSAGE | QS_HOTKEY | QS_TIMER) << 16) ;
! : PM_QS_PAINT (QS_PAINT << 16) ; ! : PM_QS_PAINT (QS_PAINT << 16) ;
@ -140,22 +142,22 @@ IN: windows.user32
! !
! Standard Cursor IDs ! Standard Cursor IDs
! !
: IDC_ARROW 32512 ; : IDC_ARROW 32512 ; inline
: IDC_IBEAM 32513 ; : IDC_IBEAM 32513 ; inline
: IDC_WAIT 32514 ; : IDC_WAIT 32514 ; inline
: IDC_CROSS 32515 ; : IDC_CROSS 32515 ; inline
: IDC_UPARROW 32516 ; : IDC_UPARROW 32516 ; inline
: IDC_SIZE 32640 ; ! OBSOLETE: use IDC_SIZEALL : IDC_SIZE 32640 ; inline ! OBSOLETE: use IDC_SIZEALL
: IDC_ICON 32641 ; ! OBSOLETE: use IDC_ARROW : IDC_ICON 32641 ; inline ! OBSOLETE: use IDC_ARROW
: IDC_SIZENWSE 32642 ; : IDC_SIZENWSE 32642 ; inline
: IDC_SIZENESW 32643 ; : IDC_SIZENESW 32643 ; inline
: IDC_SIZEWE 32644 ; : IDC_SIZEWE 32644 ; inline
: IDC_SIZENS 32645 ; : IDC_SIZENS 32645 ; inline
: IDC_SIZEALL 32646 ; : IDC_SIZEALL 32646 ; inline
: IDC_NO 32648 ; ! not in win3.1 : IDC_NO 32648 ; inline ! not in win3.1
: IDC_HAND 32649 ; : IDC_HAND 32649 ; inline
: IDC_APPSTARTING 32650 ; ! not in win3.1 : IDC_APPSTARTING 32650 ; inline ! not in win3.1
: IDC_HELP 32651 ; : IDC_HELP 32651 ; inline
! Predefined Clipboard Formats ! Predefined Clipboard Formats
: CF_TEXT 1 ; inline : CF_TEXT 1 ; inline
@ -244,9 +246,43 @@ IN: windows.user32
: VK_DELETE HEX: 2E ; inline : VK_DELETE HEX: 2E ; inline
: VK_HELP HEX: 2F ; inline : VK_HELP HEX: 2F ; inline
! VK_0 - VK_9 are the same as ASCII '0' - '9' (0x30 - 0x39) : VK_0 CHAR: 0 ; inline
! 0x40 : unassigned : VK_1 CHAR: 1 ; inline
! VK_A - VK_Z are the same as ASCII 'A' - 'Z' (0x41 - 0x5A) : VK_2 CHAR: 2 ; inline
: VK_3 CHAR: 3 ; inline
: VK_4 CHAR: 4 ; inline
: VK_5 CHAR: 5 ; inline
: VK_6 CHAR: 6 ; inline
: VK_7 CHAR: 7 ; inline
: VK_8 CHAR: 8 ; inline
: VK_9 CHAR: 9 ; inline
: VK_A CHAR: A ; inline
: VK_B CHAR: B ; inline
: VK_C CHAR: C ; inline
: VK_D CHAR: D ; inline
: VK_E CHAR: E ; inline
: VK_F CHAR: F ; inline
: VK_G CHAR: G ; inline
: VK_H CHAR: H ; inline
: VK_I CHAR: I ; inline
: VK_J CHAR: J ; inline
: VK_K CHAR: K ; inline
: VK_L CHAR: L ; inline
: VK_M CHAR: M ; inline
: VK_N CHAR: N ; inline
: VK_O CHAR: O ; inline
: VK_P CHAR: P ; inline
: VK_Q CHAR: Q ; inline
: VK_R CHAR: R ; inline
: VK_S CHAR: S ; inline
: VK_T CHAR: T ; inline
: VK_U CHAR: U ; inline
: VK_V CHAR: V ; inline
: VK_W CHAR: W ; inline
: VK_X CHAR: X ; inline
: VK_Y CHAR: Y ; inline
: VK_Z CHAR: Z ; inline
: VK_LWIN HEX: 5B ; inline : VK_LWIN HEX: 5B ; inline
: VK_RWIN HEX: 5C ; inline : VK_RWIN HEX: 5C ; inline
@ -417,47 +453,59 @@ IN: windows.user32
! Some fields are not defined for win64 ! Some fields are not defined for win64
! Window field offsets for GetWindowLong() ! Window field offsets for GetWindowLong()
: GWL_WNDPROC -4 ; : GWL_WNDPROC -4 ; inline
: GWL_HINSTANCE -6 ; : GWL_HINSTANCE -6 ; inline
: GWL_HWNDPARENT -8 ; : GWL_HWNDPARENT -8 ; inline
: GWL_USERDATA -21 ; : GWL_USERDATA -21 ; inline
: GWL_ID -12 ; : GWL_ID -12 ; inline
: GWL_STYLE -16 ; : GWL_STYLE -16 ; inline
: GWL_EXSTYLE -20 ; : GWL_EXSTYLE -20 ; inline
: GWLP_WNDPROC -4 ; : GWLP_WNDPROC -4 ; inline
: GWLP_HINSTANCE -6 ; : GWLP_HINSTANCE -6 ; inline
: GWLP_HWNDPARENT -8 ; : GWLP_HWNDPARENT -8 ; inline
: GWLP_USERDATA -21 ; : GWLP_USERDATA -21 ; inline
: GWLP_ID -12 ; : GWLP_ID -12 ; inline
! Class field offsets for GetClassLong() ! Class field offsets for GetClassLong()
: GCL_MENUNAME -8 ; : GCL_MENUNAME -8 ; inline
: GCL_HBRBACKGROUND -10 ; : GCL_HBRBACKGROUND -10 ; inline
: GCL_HCURSOR -12 ; : GCL_HCURSOR -12 ; inline
: GCL_HICON -14 ; : GCL_HICON -14 ; inline
: GCL_HMODULE -16 ; : GCL_HMODULE -16 ; inline
: GCL_WNDPROC -24 ; : GCL_WNDPROC -24 ; inline
: GCL_HICONSM -34 ; : GCL_HICONSM -34 ; inline
: GCL_CBWNDEXTRA -18 ; : GCL_CBWNDEXTRA -18 ; inline
: GCL_CBCLSEXTRA -20 ; : GCL_CBCLSEXTRA -20 ; inline
: GCL_STYLE -26 ; : GCL_STYLE -26 ; inline
: GCW_ATOM -32 ; : GCW_ATOM -32 ; inline
: GCLP_MENUNAME -8 ; : GCLP_MENUNAME -8 ; inline
: GCLP_HBRBACKGROUND -10 ; : GCLP_HBRBACKGROUND -10 ; inline
: GCLP_HCURSOR -12 ; : GCLP_HCURSOR -12 ; inline
: GCLP_HICON -14 ; : GCLP_HICON -14 ; inline
: GCLP_HMODULE -16 ; : GCLP_HMODULE -16 ; inline
: GCLP_WNDPROC -24 ; : GCLP_WNDPROC -24 ; inline
: GCLP_HICONSM -34 ; : GCLP_HICONSM -34 ; inline
: MB_ICONASTERISK HEX: 00000040 ; : MB_ICONASTERISK HEX: 00000040 ; inline
: MB_ICONEXCLAMATION HEX: 00000030 ; : MB_ICONEXCLAMATION HEX: 00000030 ; inline
: MB_ICONHAND HEX: 00000010 ; : MB_ICONHAND HEX: 00000010 ; inline
: MB_ICONQUESTION HEX: 00000020 ; : MB_ICONQUESTION HEX: 00000020 ; inline
: MB_OK HEX: 00000000 ; : MB_OK HEX: 00000000 ; inline
: FVIRTKEY TRUE ; inline
: FNOINVERT 2 ; inline
: FSHIFT 4 ; inline
: FCONTROL 8 ; inline
: FALT 16 ; inline
: MAPVK_VK_TO_VSC 0 ; inline
: MAPVK_VSC_TO_VK 1 ; inline
: MAPVK_VK_TO_CHAR 2 ; inline
: MAPVK_VSC_TO_VK_EX 3 ; inline
: MAPVK_VK_TO_VSC_EX 3 ; inline
: TME_HOVER 1 ; inline : TME_HOVER 1 ; inline
: TME_LEAVE 2 ; inline : TME_LEAVE 2 ; inline
@ -549,13 +597,15 @@ FUNCTION: BOOL CloseClipboard ( ) ;
! FUNCTION: CloseWindow ! FUNCTION: CloseWindow
! FUNCTION: CloseWindowStation ! FUNCTION: CloseWindowStation
! FUNCTION: CopyAcceleratorTableA ! FUNCTION: CopyAcceleratorTableA
! FUNCTION: CopyAcceleratorTableW FUNCTION: int CopyAcceleratorTableW ( HACCEL hAccelSrc, LPACCEL lpAccelDst, int cAccelEntries ) ;
: CopyAcceleratorTable CopyAcceleratorTableW ; inline
! FUNCTION: CopyIcon ! FUNCTION: CopyIcon
! FUNCTION: CopyImage ! FUNCTION: CopyImage
! FUNCTION: CopyRect ! FUNCTION: CopyRect
! FUNCTION: CountClipboardFormats ! FUNCTION: CountClipboardFormats
! FUNCTION: CreateAcceleratorTableA ! FUNCTION: CreateAcceleratorTableA
! FUNCTION: CreateAcceleratorTableW FUNCTION: HACCEL CreateAcceleratorTableW ( LPACCEL lpaccl, int cEntries ) ;
: CreateAcceleratorTable CreateAcceleratorTableW ; inline
! FUNCTION: CreateCaret ! FUNCTION: CreateCaret
! FUNCTION: CreateCursor ! FUNCTION: CreateCursor
! FUNCTION: CreateDesktopA ! FUNCTION: CreateDesktopA
@ -643,7 +693,7 @@ FUNCTION: LRESULT DefWindowProcW ( HWND hWnd, UINT Msg, WPARAM wParam, LPARAM lP
: DefWindowProc DefWindowProcW ; inline : DefWindowProc DefWindowProcW ; inline
! FUNCTION: DeleteMenu ! FUNCTION: DeleteMenu
! FUNCTION: DeregisterShellHookWindow ! FUNCTION: DeregisterShellHookWindow
! FUNCTION: DestroyAcceleratorTable FUNCTION: BOOL DestroyAcceleratorTable ( HACCEL hAccel ) ;
! FUNCTION: DestroyCaret ! FUNCTION: DestroyCaret
! FUNCTION: DestroyCursor ! FUNCTION: DestroyCursor
! FUNCTION: DestroyIcon ! FUNCTION: DestroyIcon
@ -953,7 +1003,7 @@ FUNCTION: BOOL IsZoomed ( HWND hWnd ) ;
! FUNCTION: KillSystemTimer ! FUNCTION: KillSystemTimer
! FUNCTION: KillTimer ! FUNCTION: KillTimer
! FUNCTION: LoadAcceleratorsA ! FUNCTION: LoadAcceleratorsA
! FUNCTION: LoadAcceleratorsW FUNCTION: HACCEL LoadAcceleratorsW ( HINSTANCE hInstance, LPCTSTR lpTableName ) ;
! FUNCTION: LoadBitmapA ! FUNCTION: LoadBitmapA
! FUNCTION: LoadBitmapW ! FUNCTION: LoadBitmapW
! FUNCTION: LoadCursorFromFileA ! FUNCTION: LoadCursorFromFileA
@ -988,10 +1038,13 @@ FUNCTION: HICON LoadIconW ( HINSTANCE hInstance, LPCTSTR lpIconName ) ;
! FUNCTION: LookupIconIdFromDirectory ! FUNCTION: LookupIconIdFromDirectory
! FUNCTION: LookupIconIdFromDirectoryEx ! FUNCTION: LookupIconIdFromDirectoryEx
! FUNCTION: MapDialogRect ! FUNCTION: MapDialogRect
! FUNCTION: MapVirtualKeyA
! FUNCTION: MapVirtualKeyExA FUNCTION: UINT MapVirtualKeyW ( UINT uCode, UINT uMapType ) ;
! FUNCTION: MapVirtualKeyExW : MapVirtualKey MapVirtualKeyW ; inline
! FUNCTION: MapVirtualKeyW
FUNCTION: UINT MapVirtualKeyExW ( UINT uCode, UINT uMapType, HKL dwhkl ) ;
: MapVirtualKeyEx MapVirtualKeyExW ; inline
! FUNCTION: MapWindowPoints ! FUNCTION: MapWindowPoints
! FUNCTION: MB_GetString ! FUNCTION: MB_GetString
! FUNCTION: MBToWCSEx ! FUNCTION: MBToWCSEx
@ -1050,7 +1103,6 @@ FUNCTION: int MessageBoxExW (
! FUNCTION: mouse_event ! FUNCTION: mouse_event
FUNCTION: BOOL MoveWindow ( FUNCTION: BOOL MoveWindow (
HWND hWnd, HWND hWnd,
int X, int X,
@ -1059,7 +1111,6 @@ FUNCTION: BOOL MoveWindow (
int nHeight, int nHeight,
BOOL bRepaint ) ; BOOL bRepaint ) ;
! FUNCTION: MsgWaitForMultipleObjects ! FUNCTION: MsgWaitForMultipleObjects
! FUNCTION: MsgWaitForMultipleObjectsEx ! FUNCTION: MsgWaitForMultipleObjectsEx
! FUNCTION: NotifyWinEvent ! FUNCTION: NotifyWinEvent
@ -1264,7 +1315,9 @@ FUNCTION: BOOL TrackMouseEvent ( LPTRACKMOUSEEVENT lpEventTrack ) ;
! FUNCTION: TrackPopupMenuEx ! FUNCTION: TrackPopupMenuEx
! FUNCTION: TranslateAccelerator ! FUNCTION: TranslateAccelerator
! FUNCTION: TranslateAcceleratorA ! FUNCTION: TranslateAcceleratorA
! FUNCTION: TranslateAcceleratorW FUNCTION: int TranslateAcceleratorW ( HWND hWnd, HACCEL hAccTable, LPMSG lpMsg ) ;
: TranslateAccelerator TranslateAcceleratorW ; inline
! FUNCTION: TranslateMDISysAccel ! FUNCTION: TranslateMDISysAccel
FUNCTION: BOOL TranslateMessage ( MSG* lpMsg ) ; FUNCTION: BOOL TranslateMessage ( MSG* lpMsg ) ;

56
extra/xmode/catalog/catalog.factor
View File

@ -1,5 +1,6 @@
USING: xmode.loader xmode.utilities namespaces USING: xmode.loader xmode.utilities xmode.rules namespaces
assocs sequences kernel io.files xml memoize words globs ; strings splitting assocs sequences kernel io.files xml memoize
words globs ;
IN: xmode.catalog IN: xmode.catalog
TUPLE: mode file file-name-glob first-line-glob ; TUPLE: mode file file-name-glob first-line-glob ;
@ -34,11 +35,60 @@ TAGS>
: reset-catalog ( -- ) : reset-catalog ( -- )
f \ modes set-global ; f \ modes set-global ;
MEMO: load-mode ( name -- rule-sets ) MEMO: (load-mode) ( name -- rule-sets )
modes at mode-file modes at mode-file
"extra/xmode/modes/" swap append "extra/xmode/modes/" swap append
resource-path <file-reader> parse-mode ; resource-path <file-reader> parse-mode ;
DEFER: load-mode
SYMBOL: rule-sets
: get-rule-set ( name -- rules )
dup string? [
"::" split1 [ swap load-mode ] [ rule-sets get ] if* at
] when ;
: resolve-delegate ( rule -- )
dup rule-delegate dup
[ get-rule-set swap set-rule-delegate ] [ 2drop ] if ;
: each-rule ( rule-set quot -- )
>r rule-set-rules values concat r> each ; inline
: resolve-delegates ( ruleset -- )
[ resolve-delegate ] each-rule ;
: ?update ( keyword-map/f keyword-map -- keyword-map )
over [ dupd update ] [ nip clone ] if ;
: import-keywords ( parent child -- )
over >r [ rule-set-keywords ] 2apply ?update
r> set-rule-set-keywords ;
: import-rules ( parent child -- )
swap [ add-rule ] curry each-rule ;
: resolve-imports ( ruleset -- )
dup rule-set-imports [
get-rule-set
dup resolve-delegates
2dup import-keywords
import-rules
] curry* each ;
: finalize-rule-set ( ruleset -- )
dup rule-set-finalized? [ drop ] [
t over set-rule-set-finalized?
dup resolve-imports
resolve-delegates
] if ;
: load-mode ( name -- rule-sets )
(load-mode) dup rule-sets [
dup [ nip finalize-rule-set ] assoc-each
] with-variable ;
: reset-modes ( -- ) : reset-modes ( -- )
\ load-mode "memoize" word-prop clear-assoc ; \ load-mode "memoize" word-prop clear-assoc ;

6
extra/xmode/marker/marker-tests.factor
View File

@ -127,3 +127,9 @@ IN: temporary
] [ ] [
f "Comment {XXX}" "rebol" load-mode tokenize-line nip f "Comment {XXX}" "rebol" load-mode tokenize-line nip
] unit-test ] unit-test
[
] [
f "font:75%/1.6em \"Lucida Grande\", \"Lucida Sans Unicode\", verdana, geneva, sans-serif;" "css" load-mode tokenize-line 2drop
] unit-test

46
extra/xmode/marker/marker.factor
View File

@ -24,18 +24,8 @@ strings regexp splitting parser-combinators ;
: mark-number ( keyword -- id ) : mark-number ( keyword -- id )
keyword-number? DIGIT and ; keyword-number? DIGIT and ;
: resolve-delegate ( name -- rules )
dup string? [
"::" split1 [ swap load-mode ] [ rule-sets get ] if* at
] when ;
: rule-set-keyword-maps ( ruleset -- seq )
dup rule-set-imports
[ resolve-delegate rule-set-keyword-maps ] map concat
swap rule-set-keywords add ;
: mark-keyword ( keyword -- id ) : mark-keyword ( keyword -- id )
current-rule-set rule-set-keyword-maps assoc-stack ; current-rule-set rule-set-keywords at ;
: add-remaining-token ( -- ) : add-remaining-token ( -- )
current-rule-set rule-set-default prev-token, ; current-rule-set rule-set-default prev-token, ;
@ -102,10 +92,6 @@ M: regexp text-matches?
DEFER: get-rules DEFER: get-rules
: get-imported-rules ( vector/f char ruleset -- vector/f )
rule-set-imports
[ resolve-delegate get-rules ?push-all ] curry* each ;
: get-always-rules ( vector/f ruleset -- vector/f ) : get-always-rules ( vector/f ruleset -- vector/f )
f swap rule-set-rules at ?push-all ; f swap rule-set-rules at ?push-all ;
@ -113,10 +99,7 @@ DEFER: get-rules
>r ch>upper r> rule-set-rules at ?push-all ; >r ch>upper r> rule-set-rules at ?push-all ;
: get-rules ( char ruleset -- seq ) : get-rules ( char ruleset -- seq )
f -rot f -rot [ get-char-rules ] keep get-always-rules ;
[ get-char-rules ] 2keep
[ get-always-rules ] keep
get-imported-rules ;
GENERIC: handle-rule-start ( match-count rule -- ) GENERIC: handle-rule-start ( match-count rule -- )
@ -173,7 +156,7 @@ M: seq-rule handle-rule-start
mark-token mark-token
add-remaining-token add-remaining-token
tuck rule-body-token next-token, tuck rule-body-token next-token,
rule-delegate [ resolve-delegate push-context ] when* ; rule-delegate [ push-context ] when* ;
UNION: abstract-span-rule span-rule eol-span-rule ; UNION: abstract-span-rule span-rule eol-span-rule ;
@ -184,7 +167,7 @@ M: abstract-span-rule handle-rule-start
tuck rule-match-token* next-token, tuck rule-match-token* next-token,
! ... end subst ... ! ... end subst ...
dup context get set-line-context-in-rule dup context get set-line-context-in-rule
rule-delegate resolve-delegate push-context ; rule-delegate push-context ;
M: span-rule handle-rule-end M: span-rule handle-rule-end
2drop ; 2drop ;
@ -230,10 +213,12 @@ M: mark-previous-rule handle-rule-start
: handle-no-word-break ( -- ) : handle-no-word-break ( -- )
context get line-context-parent [ context get line-context-parent [
line-context-in-rule dup rule-no-word-break? [ line-context-in-rule [
rule-match-token* prev-token, dup rule-no-word-break? [
pop-context rule-match-token* prev-token,
] [ drop ] if pop-context
] [ drop ] if
] when*
] when* ; ] when* ;
: check-rule ( -- ) : check-rule ( -- )
@ -300,14 +285,17 @@ M: mark-previous-rule handle-rule-start
: unwind-no-line-break ( -- ) : unwind-no-line-break ( -- )
context get line-context-parent [ context get line-context-parent [
line-context-in-rule rule-no-line-break? [ line-context-in-rule [
pop-context rule-no-line-break? [
unwind-no-line-break pop-context
] when unwind-no-line-break
] when
] when*
] when* ; ] when* ;
: tokenize-line ( line-context line rules -- line-context' seq ) : tokenize-line ( line-context line rules -- line-context' seq )
[ [
"MAIN" swap at -rot
init-token-marker init-token-marker
mark-token-loop mark-token-loop
mark-remaining mark-remaining

15
extra/xmode/marker/state/state.factor
View File

@ -4,7 +4,6 @@ IN: xmode.marker.state
! Based on org.gjt.sp.jedit.syntax.TokenMarker ! Based on org.gjt.sp.jedit.syntax.TokenMarker
SYMBOL: rule-sets
SYMBOL: line SYMBOL: line
SYMBOL: last-offset SYMBOL: last-offset
SYMBOL: position SYMBOL: position
@ -37,12 +36,6 @@ SYMBOL: delegate-end-escaped?
>r position get 2dup + r> token, >r position get 2dup + r> token,
position get + dup 1- position set last-offset set ; position get + dup 1- position set last-offset set ;
: get-rule-set ( name -- rule-set )
rule-sets get at ;
: main-rule-set ( -- rule-set )
"MAIN" get-rule-set ;
: push-context ( rules -- ) : push-context ( rules -- )
context [ <line-context> ] change ; context [ <line-context> ] change ;
@ -51,12 +44,10 @@ SYMBOL: delegate-end-escaped?
dup context set dup context set
f swap set-line-context-in-rule ; f swap set-line-context-in-rule ;
: init-token-marker ( prev-context line rules -- ) : init-token-marker ( main prev-context line -- )
rule-sets set
line set line set
[ ] [ f <line-context> ] ?if context set
0 position set 0 position set
0 last-offset set 0 last-offset set
0 whitespace-end set 0 whitespace-end set
process-escape? on process-escape? on ;
[ clone ] [ main-rule-set f <line-context> ] if*
context set ;

3
extra/xmode/modes/catalog
View File

@ -125,6 +125,9 @@
<MODE NAME="eiffel" FILE="eiffel.xml" <MODE NAME="eiffel" FILE="eiffel.xml"
FILE_NAME_GLOB="*.e" /> FILE_NAME_GLOB="*.e" />
<MODE NAME="fhtml" FILE="fhtml.xml"
FILE_NAME_GLOB="*.{furnace,fhtml}" />
<MODE NAME="factor" FILE="factor.xml" <MODE NAME="factor" FILE="factor.xml"
FILE_NAME_GLOB="*.factor"/> FILE_NAME_GLOB="*.factor"/>

49
extra/xmode/modes/fhtml.xml
View File

@ -1,25 +1,24 @@
<?xml version="1.0"?> <?xml version="1.0"?>
<!DOCTYPE MODE SYSTEM "xmode.dtd"> <!DOCTYPE MODE SYSTEM "xmode.dtd">
<!-- fhtml (factor+html) mode --> <!-- fhtml (factor+html) mode -->
<MODE> <MODE>
<PROPS> <PROPS>
<PROPERTY NAME="commentStart" VALUE="&lt;!--" /> <PROPERTY NAME="commentStart" VALUE="&lt;!--" />
<PROPERTY NAME="commentEnd" VALUE="--&gt;" /> <PROPERTY NAME="commentEnd" VALUE="--&gt;" />
<PROPERTY NAME="commentStart" VALUE="&lt;%#" /> <PROPERTY NAME="commentStart" VALUE="&lt;%#" />
<PROPERTY NAME="commentEnd" VALUE="%&gt;" /> <PROPERTY NAME="commentEnd" VALUE="%&gt;" />
<PROPERTY NAME="tabSize" VALUE="4" /> <PROPERTY NAME="tabSize" VALUE="4" />
<PROPERTY NAME="noTabs" VALUE="true" /> <PROPERTY NAME="noTabs" VALUE="true" />
</PROPS> </PROPS>
<RULES IGNORE_CASE="TRUE"> <RULES IGNORE_CASE="TRUE">
<SPAN TYPE="MARKUP" DELEGATE="factor::MAIN"> <SPAN TYPE="MARKUP" DELEGATE="factor::MAIN">
<BEGIN>&lt;%</BEGIN> <BEGIN>&lt;%</BEGIN>
<END>%&gt;</END> <END>%&gt;</END>
</SPAN> </SPAN>
<IMPORT DELEGATE="html::MAIN" /> <IMPORT DELEGATE="html::MAIN" />
</RULES> </RULES>
</MODE> </MODE>

1
extra/xmode/rules/rules.factor
View File

@ -20,6 +20,7 @@ escape-rule
highlight-digits? highlight-digits?
digit-re digit-re
no-word-sep no-word-sep
finalized?
; ;
: init-rule-set ( ruleset -- ) : init-rule-set ( ruleset -- )

2
extra/xmode/utilities/utilities-tests.factor
View File

@ -2,7 +2,7 @@ IN: temporary
USING: xmode.utilities tools.test xml xml.data USING: xmode.utilities tools.test xml xml.data
kernel strings vectors sequences io.files prettyprint assocs ; kernel strings vectors sequences io.files prettyprint assocs ;
[ 3 "hi" ] [ [ "hi" 3 ] [
{ 1 2 3 4 5 6 7 8 } [ H{ { 3 "hi" } } at ] map-find { 1 2 3 4 5 6 7 8 } [ H{ { 3 "hi" } } at ] map-find
] unit-test ] unit-test

3
vm/os-unix.c
View File

@ -219,6 +219,9 @@ static void sigaction_safe(int signum, const struct sigaction *act, struct sigac
ret = sigaction(signum, act, oldact); ret = sigaction(signum, act, oldact);
} }
while(ret == -1 && errno == EINTR); while(ret == -1 && errno == EINTR);
if(ret == -1)
fatal_error("sigaction failed", 0);
} }
void unix_init_signals(void) void unix_init_signals(void)

59
vm/os-windows.c
View File

@ -98,21 +98,22 @@ const F_CHAR *vm_executable_path(void)
return safe_strdup(full_path); return safe_strdup(full_path);
} }
DEFINE_PRIMITIVE(stat) void stat_not_found(void)
{ {
dpush(F);
dpush(F);
dpush(F);
dpush(F);
}
void find_file_stat(F_CHAR *path)
{
// FindFirstFile is the only call that can stat c:\pagefile.sys
WIN32_FIND_DATA st; WIN32_FIND_DATA st;
HANDLE h; HANDLE h;
F_CHAR *path = unbox_u16_string(); if(INVALID_HANDLE_VALUE == (h = FindFirstFile(path, &st)))
if(INVALID_HANDLE_VALUE == (h = FindFirstFile( stat_not_found();
path,
&st)))
{
dpush(F);
dpush(F);
dpush(F);
dpush(F);
}
else else
{ {
box_boolean(st.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY); box_boolean(st.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY);
@ -129,6 +130,42 @@ DEFINE_PRIMITIVE(stat)
} }
} }
DEFINE_PRIMITIVE(stat)
{
HANDLE h;
BY_HANDLE_FILE_INFORMATION bhfi;
F_CHAR *path = unbox_u16_string();
//wprintf(L"path = %s\n", path);
h = CreateFileW(path,
GENERIC_READ,
FILE_SHARE_READ,
NULL,
OPEN_EXISTING,
FILE_FLAG_BACKUP_SEMANTICS,
NULL);
if(h == INVALID_HANDLE_VALUE)
{
find_file_stat(path);
return;
}
if(!GetFileInformationByHandle(h, &bhfi))
stat_not_found();
else {
box_boolean(bhfi.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY);
dpush(tag_fixnum(0));
box_unsigned_8(
(u64)bhfi.nFileSizeLow | (u64)bhfi.nFileSizeHigh << 32);
u64 lo = bhfi.ftLastWriteTime.dwLowDateTime;
u64 hi = bhfi.ftLastWriteTime.dwHighDateTime;
u64 modTime = (hi << 32) + lo;
box_unsigned_8((modTime - EPOCH_OFFSET) / 10000000);
}
CloseHandle(h);
}
DEFINE_PRIMITIVE(read_dir) DEFINE_PRIMITIVE(read_dir)
{ {
HANDLE dir; HANDLE dir;