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

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

Conflicts:

	extra/random-tester/random/random.factor
	extra/random-tester/utils/utils.factor
release
Daniel Ehrenberg 2007-12-09 02:11:26 -05:00
parent c8e63057a0 92c567c9a4
commit 717ea6206a
84 changed files with 1317 additions and 563 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
core/combinators/combinators.factor
View File

@ -78,7 +78,11 @@ M: sequence hashcode*
: hash-case>quot ( default assoc -- quot ) : hash-case>quot ( default assoc -- quot )
dup empty? [ dup empty? [
drop drop
] [
dup length 4 <= [
case>quot
] [ ] [
hash-case-table hash-dispatch-quot hash-case-table hash-dispatch-quot
[ dup hashcode >fixnum ] swap append [ dup hashcode >fixnum ] swap append
] if
] if ; ] if ;

7
core/compiler/compiler.factor
View File

@ -16,9 +16,10 @@ M: object inference-error-major? drop t ;
: begin-batch ( seq -- ) : begin-batch ( seq -- )
batch-mode on batch-mode on
[ "quiet" get [ drop ] [
"Compiling " % length # " words..." % [ "Compiling " % length # " words..." % ] "" make
] "" make print flush print flush
] if
V{ } clone compile-errors set-global ; V{ } clone compile-errors set-global ;
: compile-error. ( pair -- ) : compile-error. ( pair -- )

2
core/compiler/test/curry.factor
View File

@ -50,7 +50,7 @@ IN: temporary
global keys = global keys =
] unit-test ] unit-test
[ 3 ] [ 1 2 [ curry [ 3 ] [ 4 ] if ] compile-1 ] unit-test [ 3 ] [ 1 [ 2 ] [ curry [ 3 ] [ 4 ] if ] compile-1 ] unit-test
[ 3 ] [ t [ 3 [ ] curry 4 [ ] curry if ] compile-1 ] unit-test [ 3 ] [ t [ 3 [ ] curry 4 [ ] curry if ] compile-1 ] unit-test

5
core/compiler/test/simple.factor
View File

@ -56,3 +56,8 @@ IN: temporary
\ recursive compile \ recursive compile
[ ] [ t recursive ] unit-test [ ] [ t recursive ] unit-test
! Make sure error reporting works
[ [ dup ] compile-1 ] unit-test-fails
[ [ drop ] compile-1 ] unit-test-fails

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

@ -126,3 +126,17 @@ TUPLE: pathname string ;
C: <pathname> pathname C: <pathname> pathname
M: pathname <=> [ pathname-string ] compare ; M: pathname <=> [ pathname-string ] compare ;
HOOK: library-roots io-backend ( -- seq )
HOOK: binary-roots io-backend ( -- seq )
: find-file ( seq str -- path/f )
[
[ path+ exists? ] curry find nip
] keep over [ path+ ] [ drop ] if ;
: find-library ( str -- path/f )
library-roots swap find-file ;
: find-binary ( str -- path/f )
binary-roots swap find-file ;

16
core/optimizer/known-words/known-words.factor
View File

@ -8,7 +8,7 @@ assocs quotations sequences.private io.binary io.crc32
io.streams.string layouts splitting math.intervals io.streams.string layouts splitting math.intervals
math.floats.private tuples tuples.private classes math.floats.private tuples tuples.private classes
optimizer.def-use optimizer.backend optimizer.pattern-match optimizer.def-use optimizer.backend optimizer.pattern-match
float-arrays combinators.private ; float-arrays combinators.private combinators ;
! the output of <tuple> and <tuple-boa> has the class which is ! the output of <tuple> and <tuple-boa> has the class which is
! its second-to-last input ! its second-to-last input
@ -50,6 +50,20 @@ float-arrays combinators.private ;
{ [ dup disjoint-eq? ] [ [ f ] inline-literals ] } { [ dup disjoint-eq? ] [ [ f ] inline-literals ] }
} define-optimizers } define-optimizers
: literal-member? ( #call -- ? )
node-in-d peek dup value?
[ value-literal sequence? ] [ drop f ] if ;
: member-quot ( seq -- newquot )
[ [ t ] ] { } map>assoc [ drop f ] add [ nip case ] curry ;
: expand-member ( #call -- )
dup node-in-d peek value-literal member-quot splice-quot ;
\ member? {
{ [ dup literal-member? ] [ expand-member ] }
} define-optimizers
! if the result of eq? is t and the second input is a literal, ! if the result of eq? is t and the second input is a literal,
! the first input is equal to the second ! the first input is equal to the second
\ eq? [ \ eq? [

2
core/optimizer/math/math.factor
View File

@ -111,7 +111,7 @@ optimizer.def-use generic.standard ;
: post-process ( class interval node -- classes intervals ) : post-process ( class interval node -- classes intervals )
dupd won't-overflow? dupd won't-overflow?
[ >r dup { f integer } memq? [ drop fixnum ] when r> ] when [ >r dup { f integer } member? [ drop fixnum ] when r> ] when
[ dup [ 1array ] when ] 2apply ; [ dup [ 1array ] when ] 2apply ;
: math-output-interval-1 ( node word -- interval ) : math-output-interval-1 ( node word -- interval )

2
extra/benchmark/reverse-complement/reverse-complement.factor
View File

@ -26,6 +26,8 @@ HINTS: do-trans-map string ;
over push over push
] if ; ] if ;
HINTS: do-line vector string ;
: (reverse-complement) ( seq -- ) : (reverse-complement) ( seq -- )
readln [ do-line (reverse-complement) ] [ show-seq ] if* ; readln [ do-line (reverse-complement) ] [ show-seq ] if* ;

25
extra/calendar/calendar.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.
USING: arrays hashtables io io.streams.string kernel math USING: arrays hashtables io io.streams.string kernel math
math.vectors math.functions math.parser math.vectors math.functions math.parser namespaces sequences
namespaces sequences strings tuples system ; strings tuples system debugger ;
IN: calendar IN: calendar
TUPLE: timestamp year month day hour minute second gmt-offset ; TUPLE: timestamp year month day hour minute second gmt-offset ;
@ -318,6 +318,27 @@ M: timestamp <=> ( ts1 ts2 -- n )
(timestamp>rfc3339) (timestamp>rfc3339)
] string-out ; ] string-out ;
: expect read1 assert= ;
: (rfc3339>timestamp) ( -- timestamp )
4 read string>number ! year
CHAR: - expect
2 read string>number ! month
CHAR: - expect
2 read string>number ! day
CHAR: T expect
2 read string>number ! hour
CHAR: : expect
2 read string>number ! minute
CHAR: : expect
2 read string>number ! second
0 <timestamp> ;
: rfc3339>timestamp ( str -- timestamp )
[
(rfc3339>timestamp)
] string-in ;
: file-time-string ( timestamp -- string ) : file-time-string ( timestamp -- string )
[ [
[ timestamp-month month-abbreviations nth write ] keep bl [ timestamp-month month-abbreviations nth write ] keep bl

4
extra/delegate/delegate.factor
View File

@ -65,8 +65,8 @@ PROTOCOL: prettyprint-section-protocol
: define-mimic ( group mimicker mimicked -- ) : define-mimic ( group mimicker mimicked -- )
>r >r group-words r> r> [ >r >r group-words r> r> [
pick "methods" word-prop at pick "methods" word-prop at dup
[ method-def <method> spin define-method ] [ 3drop ] if* [ method-def <method> spin define-method ] [ 3drop ] if
] 2curry each ; ] 2curry each ;
: MIMIC: : MIMIC:

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

@ -0,0 +1 @@
Doug Coleman

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

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

13
extra/editors/wordpad/wordpad.factor Normal file
View File

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

57
extra/furnace/furnace.factor
View File

@ -5,7 +5,7 @@ USING: kernel vectors io assocs quotations splitting strings
continuations tuples classes io.files continuations tuples classes io.files
http http.server.templating http.basic-authentication http http.server.templating http.basic-authentication
webapps.callback html html.elements webapps.callback html html.elements
http.server.responders furnace.validator ; http.server.responders furnace.validator vocabs ;
IN: furnace IN: furnace
SYMBOL: default-action SYMBOL: default-action
@ -101,36 +101,14 @@ SYMBOL: request-params
: service-post ( url -- ) "response" get swap service-request ; : service-post ( url -- ) "response" get swap service-request ;
: explode-tuple ( tuple -- ) : send-resource ( name -- )
dup tuple-slots swap class "slot-names" word-prop template-path get swap path+ resource-path <file-reader>
[ set ] 2each ; stdio get stream-copy ;
SYMBOL: model : render-template ( template -- )
template-path get swap path+
: call-template ( model template -- ) ".furnace" append resource-path
[ run-template-file ;
>r [ dup model set explode-tuple ] when* r>
".furnace" append resource-path run-template-file
] with-scope ;
: render-template ( model template -- )
template-path get swap path+ call-template ;
: render-page* ( model body-template head-template -- )
[
[ render-template ] [ f rot render-template ] html-document
] serve-html ;
: render-titled-page* ( model body-template head-template title -- )
[
[ render-template ] swap [ <title> write </title> f rot render-template ] curry html-document
] serve-html ;
: render-page ( model template title -- )
[
[ render-template ] simple-html-document
] serve-html ;
: web-app ( name default path -- ) : web-app ( name default path -- )
[ [
@ -141,3 +119,22 @@ SYMBOL: model
[ service-post ] "post" set [ service-post ] "post" set
! [ service-head ] "head" set ! [ service-head ] "head" set
] make-responder ; ] make-responder ;
: explode-tuple ( tuple -- )
dup tuple-slots swap class "slot-names" word-prop
[ set ] 2each ;
SYMBOL: model
: with-slots ( model quot -- )
[
>r [ dup model set explode-tuple ] when* r> call
] with-scope ;
: render-component ( model template -- )
swap [ render-template ] with-slots ;
: browse-webapp-source ( vocab -- )
<a f >vocab-link browser-link-href =href a>
"Browse source" write
</a> ;

4
extra/hardware-info/windows/ce/ce.factor
View File

@ -1,7 +1,7 @@
USING: alien.c-types hardware-info kernel math namespaces windows windows.kernel32 ; USING: alien.c-types hardware-info hardware-info.windows
kernel math namespaces windows windows.kernel32 ;
IN: hardware-info.windows.ce IN: hardware-info.windows.ce
TUPLE: wince ;
T{ wince } os set-global T{ wince } os set-global
: memory-status ( -- MEMORYSTATUS ) : memory-status ( -- MEMORYSTATUS )

4
extra/hardware-info/windows/nt/nt.factor
View File

@ -1,8 +1,8 @@
USING: alien alien.c-types hardware-info kernel libc math namespaces USING: alien alien.c-types hardware-info hardware-info.windows
kernel libc math namespaces
windows windows.advapi32 windows.kernel32 ; windows windows.advapi32 windows.kernel32 ;
IN: hardware-info.windows.nt IN: hardware-info.windows.nt
TUPLE: winnt ;
T{ winnt } os set-global T{ winnt } os set-global
: memory-status ( -- MEMORYSTATUSEX ) : memory-status ( -- MEMORYSTATUSEX )

19
extra/hardware-info/windows/windows.factor
View File

@ -1,5 +1,6 @@
USING: alien alien.c-types kernel libc math namespaces USING: alien alien.c-types kernel libc math namespaces
windows windows.kernel32 windows.advapi32 hardware-info ; windows windows.kernel32 windows.advapi32 hardware-info
words ;
IN: hardware-info.windows IN: hardware-info.windows
TUPLE: wince ; TUPLE: wince ;
@ -53,6 +54,22 @@ M: windows cpus ( -- n )
: sse3? ( -- ? ) : sse3? ( -- ? )
PF_SSE3_INSTRUCTIONS_AVAILABLE feature-present? ; PF_SSE3_INSTRUCTIONS_AVAILABLE feature-present? ;
: <u16-string-object> ( n -- obj )
"ushort" <c-array> ;
: get-directory ( word -- str )
>r MAX_UNICODE_PATH [ <u16-string-object> ] keep dupd r>
execute win32-error=0/f alien>u16-string ; inline
: windows-directory ( -- str )
\ GetWindowsDirectory get-directory ;
: system-directory ( -- str )
\ GetSystemDirectory get-directory ;
: system-windows-directory ( -- str )
\ GetSystemWindowsDirectory get-directory ;
USE-IF: wince? hardware-info.windows.ce USE-IF: wince? hardware-info.windows.ce
USE-IF: winnt? hardware-info.windows.nt USE-IF: winnt? hardware-info.windows.nt

15
extra/help/handbook/handbook.factor
View File

@ -235,6 +235,7 @@ ARTICLE: "changes" "Changes in the latest release"
{ "New, efficient implementations of " { $link bit? } " and " { $link log2 } " runs in constant time for large bignums" } { "New, efficient implementations of " { $link bit? } " and " { $link log2 } " runs in constant time for large bignums" }
{ "New " { $link big-random } " word for generating large random numbers quickly" } { "New " { $link big-random } " word for generating large random numbers quickly" }
{ "Improved profiler no longer has to be explicitly enabled and disabled with a full recompile; instead, the " { $link profile } " word can be used at any time, and it dynamically patches words to increment call counts. There is no overhead when the profiler is not in use." } { "Improved profiler no longer has to be explicitly enabled and disabled with a full recompile; instead, the " { $link profile } " word can be used at any time, and it dynamically patches words to increment call counts. There is no overhead when the profiler is not in use." }
{ "Calls to " { $link member? } " with a literal sequence are now open-coded. If there are four or fewer elements, a series of conditionals are generated; if there are more than four elements, there is a hash dispatch followed by conditionals in each branch." }
} }
{ $subheading "IO" } { $subheading "IO" }
{ $list { $list
@ -247,7 +248,7 @@ ARTICLE: "changes" "Changes in the latest release"
{ { $vocab-link "io.server" } " - improved logging support, logs to a file by default" } { { $vocab-link "io.server" } " - improved logging support, logs to a file by default" }
{ { $vocab-link "io.files" } " - several new file system manipulation words added" } { { $vocab-link "io.files" } " - several new file system manipulation words added" }
{ { $vocab-link "tar" } " - tar file extraction in pure Factor (Doug Coleman)" } { { $vocab-link "tar" } " - tar file extraction in pure Factor (Doug Coleman)" }
{ { $vocab-link "unix.linux" } ", " { $vocab-link "raptor" } " - ``Raptor Linux'', a set of alien bindings to low-level Linux features, such as network interface configuration, file system mounting/unmounting, etc, together with experimental boot scripts intended to entirely replace " { $snippet "/sbin/init" } ", " { $vocab-link "/etc/inittab" } " and " { $snippet "/etc/init.d/" } " (Eduardo Cavazos)." } { { $vocab-link "unix.linux" } ", " { $vocab-link "raptor" } " - ``Raptor Linux'', a set of alien bindings to low-level Linux features, such as network interface configuration, file system mounting/unmounting, etc, together with experimental boot scripts intended to entirely replace " { $snippet "/sbin/init" } ", " { $snippet "/etc/inittab" } " and " { $snippet "/etc/init.d/" } " (Eduardo Cavazos)." }
} }
{ $subheading "Tools" } { $subheading "Tools" }
{ $list { $list
@ -264,7 +265,7 @@ ARTICLE: "changes" "Changes in the latest release"
{ "Windows can be closed on request now using " { $link close-window } } { "Windows can be closed on request now using " { $link close-window } }
{ "New icons (Elie Chaftari)" } { "New icons (Elie Chaftari)" }
} }
{ $subheading "Other" } { $subheading "Libraries" }
{ $list { $list
{ "The " { $snippet "queues" } " vocabulary has been removed because its functionality is a subset of " { $vocab-link "dlists" } } { "The " { $snippet "queues" } " vocabulary has been removed because its functionality is a subset of " { $vocab-link "dlists" } }
{ "The " { $vocab-link "webapps.cgi" } " vocabulary implements CGI support for the Factor HTTP server." } { "The " { $vocab-link "webapps.cgi" } " vocabulary implements CGI support for the Factor HTTP server." }
@ -273,11 +274,19 @@ ARTICLE: "changes" "Changes in the latest release"
{ { $vocab-link "channels" } " - concurrent message passing over message channels" } { { $vocab-link "channels" } " - concurrent message passing over message channels" }
{ { $vocab-link "destructors" } " - deterministic scope-based resource deallocation (Doug Coleman)" } { { $vocab-link "destructors" } " - deterministic scope-based resource deallocation (Doug Coleman)" }
{ { $vocab-link "dlists" } " - various updates (Doug Coleman)" } { { $vocab-link "dlists" } " - various updates (Doug Coleman)" }
{ { $vocab-link "editors.emeditor" } " - EmEditor integration (Doug Coleman)" }
{ { $vocab-link "editors.editplus" } " - EditPlus integration (Aaron Schaefer)" }
{ { $vocab-link "editors.notepadpp" } " - Notepad++ integration (Doug Coleman)" } { { $vocab-link "editors.notepadpp" } " - Notepad++ integration (Doug Coleman)" }
{ { $vocab-link "editors.ted-notepad" } " - TED Notepad integration (Doug Coleman)" }
{ { $vocab-link "editors.ultraedit" } " - UltraEdit integration (Doug Coleman)" }
{ { $vocab-link "globs" } " - simple Unix shell-style glob patterns" }
{ { $vocab-link "heaps" } " - updated for new module system and cleaned up (Doug Coleman)" } { { $vocab-link "heaps" } " - updated for new module system and cleaned up (Doug Coleman)" }
{ { $vocab-link "peg" } " - Parser Expression Grammars, a new appoach to parser construction, similar to parser combinators (Chris Double)" } { { $vocab-link "peg" } " - Parser Expression Grammars, a new appoach to parser construction, similar to parser combinators (Chris Double)" }
{ { $vocab-link "regexp" } " - revived from " { $snippet "unmaintained/" } " and completely redesigned (Doug Coleman)" } { { $vocab-link "regexp" } " - revived from " { $snippet "unmaintained/" } " and completely redesigned (Doug Coleman)" }
{ { $vocab-link "tuple.lib" } " - some utility words for working with tuples (Doug Coleman)" } { { $vocab-link "rss" } " - add Atom feed generation (Daniel Ehrenberg)" }
{ { $vocab-link "tuples.lib" } " - some utility words for working with tuples (Doug Coleman)" }
{ { $vocab-link "webapps.pastebin" } " - improved appearance, add Atom feed generation, add syntax highlighting using " { $vocab-link "xmode" } }
{ { $vocab-link "webapps.planet" } " - add Atom feed generation" }
} }
{ $heading "Factor 0.90" } { $heading "Factor 0.90" }
{ $subheading "Core" } { $subheading "Core" }

2
extra/http/http.factor
View File

@ -20,7 +20,7 @@ IN: http
dup letter? dup letter?
over LETTER? or over LETTER? or
over digit? or over digit? or
swap "/_?." member? or ; foldable swap "/_-?." member? or ; foldable
: url-encode ( str -- str ) : url-encode ( str -- str )
[ [

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

@ -38,3 +38,21 @@ 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"
} ;

3
extra/io/windows/ce/files/files.factor
View File

@ -7,7 +7,8 @@ IN: windows.ce.files
! M: windows-ce-io normalize-pathname ( string -- string ) ! M: windows-ce-io normalize-pathname ( string -- string )
! dup 1 tail* CHAR: \\ = [ "*" append ] [ "\\*" append ] if ; ! dup 1 tail* CHAR: \\ = [ "*" append ] [ "\\*" append ] if ;
M: windows-ce-io CreateFile-flags ( -- DWORD ) FILE_ATTRIBUTE_NORMAL ; M: windows-ce-io CreateFile-flags ( DWORD -- DWORD )
FILE_ATTRIBUTE_NORMAL bitor ;
M: windows-ce-io FileArgs-overlapped ( port -- f ) drop f ; M: windows-ce-io FileArgs-overlapped ( port -- f ) drop f ;
: finish-read ( port status bytes-ret -- ) : finish-read ( port status bytes-ret -- )

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

@ -87,9 +87,9 @@ TUPLE: CreateProcess-args
pass-environment? [ pass-environment? [
[ [
get-environment get-environment
[ swap % "=" % % "\0" % ] assoc-each [ "=" swap 3append string>u16-alien % ] assoc-each
"\0" % "\0" %
] "" make >c-ushort-array ] { } make >c-ushort-array
over set-CreateProcess-args-lpEnvironment over set-CreateProcess-args-lpEnvironment
] when ; ] when ;

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

@ -62,7 +62,7 @@ M: windows-ce-io with-privileges
: mmap-open ( path access-mode create-mode flProtect access -- handle handle address ) : mmap-open ( path access-mode create-mode flProtect access -- handle handle address )
{ "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [ { "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [
>r >r open-file dup f r> 0 0 f >r >r 0 open-file dup f r> 0 0 f
CreateFileMapping [ win32-error=0/f ] keep CreateFileMapping [ win32-error=0/f ] keep
dup close-later dup close-later
dup dup

4
extra/io/windows/nt/files/files.factor
View File

@ -3,8 +3,8 @@ io.windows.nt io.windows.nt.backend kernel libc math
threads windows windows.kernel32 ; threads windows windows.kernel32 ;
IN: io.windows.nt.files IN: io.windows.nt.files
M: windows-nt-io CreateFile-flags ( -- DWORD ) M: windows-nt-io CreateFile-flags ( DWORD -- DWORD )
FILE_FLAG_OVERLAPPED ; FILE_FLAG_OVERLAPPED bitor ;
M: windows-nt-io FileArgs-overlapped ( port -- overlapped ) M: windows-nt-io FileArgs-overlapped ( port -- overlapped )
make-overlapped ; make-overlapped ;

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

@ -4,13 +4,23 @@ USING: alien alien.c-types arrays destructors io io.backend
io.buffers io.files io.nonblocking io.sockets io.binary io.buffers io.files io.nonblocking io.sockets io.binary
io.sockets.impl windows.errors strings io.streams.duplex kernel io.sockets.impl windows.errors strings io.streams.duplex kernel
math namespaces sequences windows windows.kernel32 math namespaces sequences windows windows.kernel32
windows.winsock splitting ; windows.shell32 windows.winsock splitting ;
IN: io.windows IN: io.windows
TUPLE: windows-nt-io ; 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 ;
@ -23,7 +33,7 @@ TUPLE: win32-file handle ptr overlapped ;
: <win32-duplex-stream> ( in out -- stream ) : <win32-duplex-stream> ( in out -- stream )
>r f <win32-file> r> f <win32-file> handle>duplex-stream ; >r f <win32-file> r> f <win32-file> handle>duplex-stream ;
HOOK: CreateFile-flags io-backend ( -- DWORD ) HOOK: CreateFile-flags io-backend ( DWORD -- DWORD )
HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f ) HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
HOOK: add-completion io-backend ( port -- ) HOOK: add-completion io-backend ( port -- )
@ -31,7 +41,8 @@ M: windows-io normalize-directory ( string -- string )
"\\" ?tail drop "\\*" append ; "\\" ?tail drop "\\*" append ;
: share-mode ( -- fixnum ) : share-mode ( -- fixnum )
FILE_SHARE_READ FILE_SHARE_WRITE bitor ; inline FILE_SHARE_READ FILE_SHARE_WRITE bitor
FILE_SHARE_DELETE bitor ; foldable
M: win32-file init-handle ( handle -- ) M: win32-file init-handle ( handle -- )
drop ; drop ;
@ -40,24 +51,25 @@ M: win32-file close-handle ( handle -- )
win32-file-handle CloseHandle drop ; win32-file-handle CloseHandle drop ;
! Clean up resources (open handle) if add-completion fails ! Clean up resources (open handle) if add-completion fails
: open-file ( path access-mode create-mode -- handle ) : open-file ( path access-mode create-mode flags -- handle )
[ [
>r share-mode f r> CreateFile-flags f CreateFile >r >r >r normalize-pathname r>
share-mode f r> r> CreateFile-flags f CreateFile
dup invalid-handle? dup close-later dup invalid-handle? dup close-later
dup add-completion dup add-completion
] with-destructors ; ] with-destructors ;
: open-pipe-r/w ( path -- handle ) : open-pipe-r/w ( path -- handle )
GENERIC_READ GENERIC_WRITE bitor OPEN_EXISTING open-file ; GENERIC_READ GENERIC_WRITE bitor OPEN_EXISTING 0 open-file ;
: open-read ( path -- handle length ) : open-read ( path -- handle length )
normalize-pathname GENERIC_READ OPEN_EXISTING open-file 0 ; GENERIC_READ OPEN_EXISTING 0 open-file 0 ;
: open-write ( path -- handle length ) : open-write ( path -- handle length )
normalize-pathname GENERIC_WRITE CREATE_ALWAYS open-file 0 ; GENERIC_WRITE CREATE_ALWAYS 0 open-file 0 ;
: (open-append) ( path -- handle ) : (open-append) ( path -- handle )
normalize-pathname GENERIC_WRITE OPEN_ALWAYS open-file ; GENERIC_WRITE OPEN_ALWAYS 0 open-file ;
: set-file-pointer ( handle length -- ) : set-file-pointer ( handle length -- )
dupd d>w/w <uint> FILE_BEGIN SetFilePointer dupd d>w/w <uint> FILE_BEGIN SetFilePointer

4
extra/nehe/4/4.factor
View File

@ -57,11 +57,11 @@ M: nehe4-gadget draw-gadget* ( gadget -- )
dup nehe4-gadget-rquad 0.15 - swap set-nehe4-gadget-rquad ; dup nehe4-gadget-rquad 0.15 - swap set-nehe4-gadget-rquad ;
: nehe4-update-thread ( gadget -- ) : nehe4-update-thread ( gadget -- )
dup nehe4-gadget-quit? [ dup nehe4-gadget-quit? [ drop ] [
redraw-interval sleep redraw-interval sleep
dup relayout-1 dup relayout-1
nehe4-update-thread nehe4-update-thread
] unless ; ] if ;
M: nehe4-gadget graft* ( gadget -- ) M: nehe4-gadget graft* ( gadget -- )
[ f swap set-nehe4-gadget-quit? ] keep [ f swap set-nehe4-gadget-quit? ] keep

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

@ -1,7 +1,7 @@
! Copyright (C) 2004 Chris Double. ! Copyright (C) 2004 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: lazy-lists promises kernel sequences strings math USING: lazy-lists promises kernel sequences strings math
arrays splitting quotations combinators ; arrays splitting quotations combinators namespaces ;
IN: parser-combinators IN: parser-combinators
! Parser combinator protocol ! Parser combinator protocol
@ -30,16 +30,32 @@ C: <parse-result> parse-result
rot slice-seq <slice> rot slice-seq <slice>
] if ; ] if ;
TUPLE: token-parser string ; : string= ( str1 str2 ignore-case -- ? )
[ [ >upper ] 2apply ] when sequence= ;
C: token token-parser ( string -- parser ) : string-head? ( str head ignore-case -- ? )
pick pick shorter? [
3drop f
] [
>r [ length head-slice ] keep r> string=
] if ;
: ?string-head ( str head ignore-case -- newstr ? )
>r 2dup r> string-head?
[ length tail-slice t ] [ drop f ] if ;
TUPLE: token-parser string ignore-case? ;
C: <token-parser> token-parser
: token ( string -- parser ) f <token-parser> ;
: case-insensitive-token ( string -- parser ) t <token-parser> ;
M: token-parser parse ( input parser -- list ) M: token-parser parse ( input parser -- list )
token-parser-string swap over ?head-slice [ dup token-parser-string swap token-parser-ignore-case?
<parse-result> 1list >r tuck r> ?string-head
] [ [ <parse-result> 1list ] [ 2drop nil ] if ;
2drop nil
] if ;
: 1token ( n -- parser ) 1string token ; : 1token ( n -- parser ) 1string token ;
@ -224,7 +240,7 @@ LAZY: <*> ( parser -- parser )
LAZY: <?> ( parser -- parser ) LAZY: <?> ( parser -- parser )
#! Return a parser that optionally uses the parser #! Return a parser that optionally uses the parser
#! if that parser would be successfull. #! if that parser would be successful.
[ 1array ] <@ f succeed <|> ; [ 1array ] <@ f succeed <|> ;
TUPLE: only-first-parser p1 ; TUPLE: only-first-parser p1 ;
@ -261,6 +277,10 @@ LAZY: <!?> ( parser -- parser )
#! required. #! required.
<?> only-first ; <?> only-first ;
LAZY: <(?)> ( parser -- parser )
#! Like <?> but take shortest match first.
f succeed swap [ 1array ] <@ <|> ;
LAZY: <(*)> ( parser -- parser ) LAZY: <(*)> ( parser -- parser )
#! Like <*> but take shortest match first. #! Like <*> but take shortest match first.
#! Implementation by Matthew Willis. #! Implementation by Matthew Willis.
@ -290,8 +310,13 @@ LAZY: <(+)> ( parser -- parser )
LAZY: surrounded-by ( parser start end -- parser' ) LAZY: surrounded-by ( parser start end -- parser' )
[ token ] 2apply swapd pack ; [ token ] 2apply swapd pack ;
: flatten* ( obj -- )
dup array? [ [ flatten* ] each ] [ , ] if ;
: flatten [ flatten* ] { } make ;
: exactly-n ( parser n -- parser' ) : exactly-n ( parser n -- parser' )
swap <repetition> <and-parser> ; swap <repetition> <and-parser> [ flatten ] <@ ;
: at-most-n ( parser n -- parser' ) : at-most-n ( parser n -- parser' )
dup zero? [ dup zero? [
@ -305,4 +330,4 @@ LAZY: surrounded-by ( parser start end -- parser' )
dupd exactly-n swap <*> <&> ; dupd exactly-n swap <*> <&> ;
: from-m-to-n ( parser m n -- parser' ) : from-m-to-n ( parser m n -- parser' )
>r [ exactly-n ] 2keep r> swap - at-most-n <&> ; >r [ exactly-n ] 2keep r> swap - at-most-n <:&:> ;

1
extra/prolog/authors.txt Normal file
View File

@ -0,0 +1 @@
Gavin Harrison

84
extra/prolog/prolog.factor Normal file
View File

@ -0,0 +1,84 @@
! Copyright (C) 2007 Gavin Harrison
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences arrays vectors namespaces math strings
combinators continuations quotations io assocs ;
IN: prolog
SYMBOL: pldb
SYMBOL: plchoice
: init-pl ( -- ) V{ } clone pldb set V{ } clone plchoice set ;
: reset-choice ( -- ) V{ } clone plchoice set ;
: remove-choice ( -- ) plchoice get pop drop ;
: add-choice ( continuation -- )
dup continuation? [ plchoice get push ] [ drop ] if ;
: last-choice ( -- ) plchoice get pop continue ;
: rules ( -- vector ) pldb get ;
: rule ( n -- rule ) dup rules length >= [ drop "No." ] [ rules nth ] if ;
: var? ( pl-obj -- ? )
dup string? [ 0 swap nth LETTER? ] [ drop f ] if ;
: const? ( pl-obj -- ? ) var? not ;
: check-arity ( pat fact -- pattern fact ? ) 2dup [ length ] 2apply = ;
: check-elements ( pat fact -- ? ) [ over var? [ 2drop t ] [ = ] if ] 2all? ;
: (double-bound) ( key value assoc -- ? )
pick over at* [ pick = >r 3drop r> ] [ drop swapd set-at t ] if ;
: single-bound? ( pat-d pat-f -- ? )
H{ } clone [ (double-bound) ] curry 2all? ;
: match-pattern ( pat fact -- ? )
check-arity [ 2dup check-elements -rot single-bound? and ] [ 2drop f ] if ;
: good-result? ( pat fact -- pat fact ? )
2dup dup "No." = [ 2drop t ] [ match-pattern ] if ;
: add-rule ( name pat body -- ) 3array rules dup length swap set-nth ;
: (lookup-rule) ( name num -- pat-f rules )
dup rule dup "No." = >r 0 swap nth swapd dupd = swapd r> or
[ dup rule [ ] callcc0 add-choice ] when
dup number? [ 1+ (lookup-rule) ] [ 2nip ] if ;
: add-bindings ( pat-d pat-f binds -- binds )
clone
[ over var? over const? or
[ 2drop ] [ rot dup >r set-at r> ] if
] 2reduce ;
: init-binds ( pat-d pat-f -- binds ) V{ } clone add-bindings >alist ;
: replace-if-bound ( binds elt -- binds elt' )
over 2dup key? [ at ] [ drop ] if ;
: deep-replace ( binds seq -- binds seq' )
[ dup var? [ replace-if-bound ]
[ dup array? [ dupd deep-replace nip ] when ] if
] map ;
: backtrace? ( result -- )
dup "No." = [ remove-choice last-choice ]
[ [ last-choice ] unless ] if ;
: resolve-rule ( pat-d pat-f rule-body -- binds )
>r 2dup init-binds r> [ deep-replace >quotation call dup backtrace?
dup t = [ drop ] when ] each ;
: rule>pattern ( rule -- pattern ) 1 swap nth ;
: rule>body ( rule -- body ) 2 swap nth ;
: binds>fact ( pat-d pat-f binds -- fact )
[ 2dup key? [ at ] [ drop ] if ] curry map good-result?
[ nip ] [ last-choice ] if ;
: lookup-rule ( name pat -- fact )
swap 0 (lookup-rule) dup "No." =
[ nip ]
[ dup rule>pattern swapd check-arity
[ rot rule>body resolve-rule dup -roll binds>fact nip ] [ last-choice ] if
] if ;
: binding-resolve ( binds name pat -- binds )
tuck lookup-rule dup backtrace? swap rot add-bindings ;
: is ( binds val var -- binds ) rot [ set-at ] keep ;

1
extra/prolog/summary.txt Normal file
View File

@ -0,0 +1 @@
Implementation of an embedded prolog for factor

1
extra/prolog/tags.txt Normal file
View File

@ -0,0 +1 @@
prolog

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

@ -1,6 +1,6 @@
USING: kernel math sequences namespaces hashtables words math.functions USING: kernel math sequences namespaces hashtables words
arrays parser compiler syntax io random prettyprint optimizer layouts arrays parser compiler syntax io prettyprint optimizer
inference math.constants random-tester.utils ; random math.constants math.functions layouts random-tester.utils ;
IN: random-tester IN: random-tester
! Tweak me ! Tweak me
@ -26,7 +26,7 @@ IN: random-tester
{ } make \ special-floats set-global { } make \ special-floats set-global
: special-complexes ( -- seq ) \ special-complexes get ; : special-complexes ( -- seq ) \ special-complexes get ;
[ [
{ -1 0 1 } % -1 sqrt dup , neg , { -1 0 1 C{ 0 1 } C{ 0 -1 } } %
e , e neg , pi , pi neg , e , e neg , pi , pi neg ,
0 pi rect> , 0 pi neg rect> , pi neg 0 rect> , pi pi rect> , 0 pi rect> , 0 pi neg rect> , pi neg 0 rect> , pi pi rect> ,
pi pi neg rect> , pi neg pi rect> , pi neg pi neg rect> , pi pi neg rect> , pi neg pi rect> , pi neg pi neg rect> ,
@ -34,16 +34,16 @@ IN: random-tester
] { } make \ special-complexes set-global ] { } make \ special-complexes set-global
: random-fixnum ( -- fixnum ) : random-fixnum ( -- fixnum )
most-positive-fixnum random 1+ coin-flip [ neg 1- ] when >fixnum ; most-positive-fixnum random 1+ 50% [ neg 1- ] when >fixnum ;
: random-bignum ( -- bignum ) : random-bignum ( -- bignum )
400 random-bits first-bignum + coin-flip [ neg ] when ; 400 random-bits first-bignum + 50% [ neg ] when ;
: random-integer ( -- n ) : random-integer ( -- n )
coin-flip [ 50% [
random-fixnum random-fixnum
] [ ] [
coin-flip [ random-bignum ] [ special-integers random ] if 50% [ random-bignum ] [ special-integers get random ] if
] if ; ] if ;
: random-positive-integer ( -- int ) : random-positive-integer ( -- int )
@ -54,12 +54,12 @@ IN: random-tester
] if ; ] if ;
: random-ratio ( -- ratio ) : random-ratio ( -- ratio )
1000000000 dup [ random ] 2apply 1+ / coin-flip [ neg ] when dup [ drop random-ratio ] unless 10% [ drop 0 ] when ; 1000000000 dup [ random ] 2apply 1+ / 50% [ neg ] when dup [ drop random-ratio ] unless 10% [ drop 0 ] when ;
: random-float ( -- float ) : random-float ( -- float )
coin-flip [ random-ratio ] [ special-floats random ] if 50% [ random-ratio ] [ special-floats get random ] if
coin-flip 50%
[ .0000000000000000001 /f ] [ coin-flip [ .00000000000000001 * ] when ] if [ .0000000000000000001 /f ] [ 50% [ .00000000000000001 * ] when ] if
>float ; >float ;
: random-number ( -- number ) : random-number ( -- number )

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

@ -1,5 +1,5 @@
USING: arrays assocs combinators.lib continuations kernel USING: arrays assocs combinators.lib continuations kernel
math math.functions 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

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

@ -1,174 +1,201 @@
USING: regexp tools.test ; USING: regexp tools.test kernel ;
IN: regexp-tests IN: regexp-tests
[ f ] [ "b" "a*" matches? ] unit-test [ f ] [ "b" "a*" f <regexp> matches? ] unit-test
[ t ] [ "" "a*" matches? ] unit-test [ t ] [ "" "a*" f <regexp> matches? ] unit-test
[ t ] [ "a" "a*" matches? ] unit-test [ t ] [ "a" "a*" f <regexp> matches? ] unit-test
[ t ] [ "aaaaaaa" "a*" matches? ] unit-test [ t ] [ "aaaaaaa" "a*" f <regexp> matches? ] unit-test
[ f ] [ "ab" "a*" matches? ] unit-test [ f ] [ "ab" "a*" f <regexp> matches? ] unit-test
[ t ] [ "abc" "abc" matches? ] unit-test [ t ] [ "abc" "abc" f <regexp> matches? ] unit-test
[ t ] [ "a" "a|b|c" matches? ] unit-test [ t ] [ "a" "a|b|c" f <regexp> matches? ] unit-test
[ t ] [ "b" "a|b|c" matches? ] unit-test [ t ] [ "b" "a|b|c" f <regexp> matches? ] unit-test
[ t ] [ "c" "a|b|c" matches? ] unit-test [ t ] [ "c" "a|b|c" f <regexp> matches? ] unit-test
[ f ] [ "c" "d|e|f" matches? ] unit-test [ f ] [ "c" "d|e|f" f <regexp> matches? ] unit-test
[ f ] [ "aa" "a|b|c" matches? ] unit-test [ f ] [ "aa" "a|b|c" f <regexp> matches? ] unit-test
[ f ] [ "bb" "a|b|c" matches? ] unit-test [ f ] [ "bb" "a|b|c" f <regexp> matches? ] unit-test
[ f ] [ "cc" "a|b|c" matches? ] unit-test [ f ] [ "cc" "a|b|c" f <regexp> matches? ] unit-test
[ f ] [ "cc" "d|e|f" matches? ] unit-test [ f ] [ "cc" "d|e|f" f <regexp> matches? ] unit-test
[ f ] [ "" "a+" matches? ] unit-test [ f ] [ "" "a+" f <regexp> matches? ] unit-test
[ t ] [ "a" "a+" matches? ] unit-test [ t ] [ "a" "a+" f <regexp> matches? ] unit-test
[ t ] [ "aa" "a+" matches? ] unit-test [ t ] [ "aa" "a+" f <regexp> matches? ] unit-test
[ t ] [ "" "a?" matches? ] unit-test [ t ] [ "" "a?" f <regexp> matches? ] unit-test
[ t ] [ "a" "a?" matches? ] unit-test [ t ] [ "a" "a?" f <regexp> matches? ] unit-test
[ f ] [ "aa" "a?" matches? ] unit-test [ f ] [ "aa" "a?" f <regexp> matches? ] unit-test
[ f ] [ "" "." matches? ] unit-test [ f ] [ "" "." f <regexp> matches? ] unit-test
[ t ] [ "a" "." matches? ] unit-test [ t ] [ "a" "." f <regexp> matches? ] unit-test
[ t ] [ "." "." matches? ] unit-test [ t ] [ "." "." f <regexp> matches? ] unit-test
! [ f ] [ "\n" "." matches? ] unit-test ! [ f ] [ "\n" "." f <regexp> matches? ] unit-test
[ f ] [ "" ".+" matches? ] unit-test [ f ] [ "" ".+" f <regexp> matches? ] unit-test
[ t ] [ "a" ".+" matches? ] unit-test [ t ] [ "a" ".+" f <regexp> matches? ] unit-test
[ t ] [ "ab" ".+" matches? ] unit-test [ t ] [ "ab" ".+" f <regexp> matches? ] unit-test
[ t ] [ "" "a|b*|c+|d?" matches? ] unit-test [ t ] [ "" "a|b*|c+|d?" f <regexp> matches? ] unit-test
[ t ] [ "a" "a|b*|c+|d?" matches? ] unit-test [ t ] [ "a" "a|b*|c+|d?" f <regexp> matches? ] unit-test
[ t ] [ "c" "a|b*|c+|d?" matches? ] unit-test [ t ] [ "c" "a|b*|c+|d?" f <regexp> matches? ] unit-test
[ t ] [ "cc" "a|b*|c+|d?" matches? ] unit-test [ t ] [ "cc" "a|b*|c+|d?" f <regexp> matches? ] unit-test
[ f ] [ "ccd" "a|b*|c+|d?" matches? ] unit-test [ f ] [ "ccd" "a|b*|c+|d?" f <regexp> matches? ] unit-test
[ t ] [ "d" "a|b*|c+|d?" matches? ] unit-test [ t ] [ "d" "a|b*|c+|d?" f <regexp> matches? ] unit-test
[ t ] [ "foo" "foo|bar" matches? ] unit-test [ t ] [ "foo" "foo|bar" f <regexp> matches? ] unit-test
[ t ] [ "bar" "foo|bar" matches? ] unit-test [ t ] [ "bar" "foo|bar" f <regexp> matches? ] unit-test
[ f ] [ "foobar" "foo|bar" matches? ] unit-test [ f ] [ "foobar" "foo|bar" f <regexp> matches? ] unit-test
[ f ] [ "" "(a)" matches? ] unit-test [ f ] [ "" "(a)" f <regexp> matches? ] unit-test
[ t ] [ "a" "(a)" matches? ] unit-test [ t ] [ "a" "(a)" f <regexp> matches? ] unit-test
[ f ] [ "aa" "(a)" matches? ] unit-test [ f ] [ "aa" "(a)" f <regexp> matches? ] unit-test
[ t ] [ "aa" "(a*)" matches? ] unit-test [ t ] [ "aa" "(a*)" f <regexp> matches? ] unit-test
[ f ] [ "aababaaabbac" "(a|b)+" matches? ] unit-test [ f ] [ "aababaaabbac" "(a|b)+" f <regexp> matches? ] unit-test
[ t ] [ "ababaaabba" "(a|b)+" matches? ] unit-test [ t ] [ "ababaaabba" "(a|b)+" f <regexp> matches? ] unit-test
[ f ] [ "" "a{1}" matches? ] unit-test [ f ] [ "" "a{1}" f <regexp> matches? ] unit-test
[ t ] [ "a" "a{1}" matches? ] unit-test [ t ] [ "a" "a{1}" f <regexp> matches? ] unit-test
[ f ] [ "aa" "a{1}" matches? ] unit-test [ f ] [ "aa" "a{1}" f <regexp> matches? ] unit-test
[ f ] [ "a" "a{2,}" matches? ] unit-test [ f ] [ "a" "a{2,}" f <regexp> matches? ] unit-test
[ t ] [ "aaa" "a{2,}" matches? ] unit-test [ t ] [ "aaa" "a{2,}" f <regexp> matches? ] unit-test
[ t ] [ "aaaa" "a{2,}" matches? ] unit-test [ t ] [ "aaaa" "a{2,}" f <regexp> matches? ] unit-test
[ t ] [ "aaaaa" "a{2,}" matches? ] unit-test [ t ] [ "aaaaa" "a{2,}" f <regexp> matches? ] unit-test
[ t ] [ "" "a{,2}" matches? ] unit-test [ t ] [ "" "a{,2}" f <regexp> matches? ] unit-test
[ t ] [ "a" "a{,2}" matches? ] unit-test [ t ] [ "a" "a{,2}" f <regexp> matches? ] unit-test
[ t ] [ "aa" "a{,2}" matches? ] unit-test [ t ] [ "aa" "a{,2}" f <regexp> matches? ] unit-test
[ f ] [ "aaa" "a{,2}" matches? ] unit-test [ f ] [ "aaa" "a{,2}" f <regexp> matches? ] unit-test
[ f ] [ "aaaa" "a{,2}" matches? ] unit-test [ f ] [ "aaaa" "a{,2}" f <regexp> matches? ] unit-test
[ f ] [ "aaaaa" "a{,2}" matches? ] unit-test [ f ] [ "aaaaa" "a{,2}" f <regexp> matches? ] unit-test
[ f ] [ "" "a{1,3}" matches? ] unit-test [ f ] [ "" "a{1,3}" f <regexp> matches? ] unit-test
[ t ] [ "a" "a{1,3}" matches? ] unit-test [ t ] [ "a" "a{1,3}" f <regexp> matches? ] unit-test
[ t ] [ "aa" "a{1,3}" matches? ] unit-test [ t ] [ "aa" "a{1,3}" f <regexp> matches? ] unit-test
[ t ] [ "aaa" "a{1,3}" matches? ] unit-test [ t ] [ "aaa" "a{1,3}" f <regexp> matches? ] unit-test
[ f ] [ "aaaa" "a{1,3}" matches? ] unit-test [ f ] [ "aaaa" "a{1,3}" f <regexp> matches? ] unit-test
[ f ] [ "" "[a]" matches? ] unit-test [ f ] [ "" "[a]" f <regexp> matches? ] unit-test
[ t ] [ "a" "[a]" matches? ] unit-test [ t ] [ "a" "[a]" f <regexp> matches? ] unit-test
[ t ] [ "a" "[abc]" matches? ] unit-test [ t ] [ "a" "[abc]" f <regexp> matches? ] unit-test
[ f ] [ "b" "[a]" matches? ] unit-test [ f ] [ "b" "[a]" f <regexp> matches? ] unit-test
[ f ] [ "d" "[abc]" matches? ] unit-test [ f ] [ "d" "[abc]" f <regexp> matches? ] unit-test
[ t ] [ "ab" "[abc]{1,2}" matches? ] unit-test [ t ] [ "ab" "[abc]{1,2}" f <regexp> matches? ] unit-test
[ f ] [ "abc" "[abc]{1,2}" matches? ] unit-test [ f ] [ "abc" "[abc]{1,2}" f <regexp> matches? ] unit-test
[ f ] [ "" "[^a]" matches? ] unit-test [ f ] [ "" "[^a]" f <regexp> matches? ] unit-test
[ f ] [ "a" "[^a]" matches? ] unit-test [ f ] [ "a" "[^a]" f <regexp> matches? ] unit-test
[ f ] [ "a" "[^abc]" matches? ] unit-test [ f ] [ "a" "[^abc]" f <regexp> matches? ] unit-test
[ t ] [ "b" "[^a]" matches? ] unit-test [ t ] [ "b" "[^a]" f <regexp> matches? ] unit-test
[ t ] [ "d" "[^abc]" matches? ] unit-test [ t ] [ "d" "[^abc]" f <regexp> matches? ] unit-test
[ f ] [ "ab" "[^abc]{1,2}" matches? ] unit-test [ f ] [ "ab" "[^abc]{1,2}" f <regexp> matches? ] unit-test
[ f ] [ "abc" "[^abc]{1,2}" matches? ] unit-test [ f ] [ "abc" "[^abc]{1,2}" f <regexp> matches? ] unit-test
[ t ] [ "]" "[]]" matches? ] unit-test [ t ] [ "]" "[]]" f <regexp> matches? ] unit-test
[ f ] [ "]" "[^]]" matches? ] unit-test [ f ] [ "]" "[^]]" f <regexp> matches? ] unit-test
! [ "^" "[^]" matches? ] unit-test-fails ! [ "^" "[^]" f <regexp> matches? ] unit-test-fails
[ t ] [ "^" "[]^]" matches? ] unit-test [ t ] [ "^" "[]^]" f <regexp> matches? ] unit-test
[ t ] [ "]" "[]^]" matches? ] unit-test [ t ] [ "]" "[]^]" f <regexp> matches? ] unit-test
[ t ] [ "[" "[[]" matches? ] unit-test [ t ] [ "[" "[[]" f <regexp> matches? ] unit-test
[ f ] [ "^" "[^^]" matches? ] unit-test [ f ] [ "^" "[^^]" f <regexp> matches? ] unit-test
[ t ] [ "a" "[^^]" matches? ] unit-test [ t ] [ "a" "[^^]" f <regexp> matches? ] unit-test
[ t ] [ "-" "[-]" matches? ] unit-test [ t ] [ "-" "[-]" f <regexp> matches? ] unit-test
[ f ] [ "a" "[-]" matches? ] unit-test [ f ] [ "a" "[-]" f <regexp> matches? ] unit-test
[ f ] [ "-" "[^-]" matches? ] unit-test [ f ] [ "-" "[^-]" f <regexp> matches? ] unit-test
[ t ] [ "a" "[^-]" matches? ] unit-test [ t ] [ "a" "[^-]" f <regexp> matches? ] unit-test
[ t ] [ "-" "[-a]" matches? ] unit-test [ t ] [ "-" "[-a]" f <regexp> matches? ] unit-test
[ t ] [ "a" "[-a]" matches? ] unit-test [ t ] [ "a" "[-a]" f <regexp> matches? ] unit-test
[ t ] [ "-" "[a-]" matches? ] unit-test [ t ] [ "-" "[a-]" f <regexp> matches? ] unit-test
[ t ] [ "a" "[a-]" matches? ] unit-test [ t ] [ "a" "[a-]" f <regexp> matches? ] unit-test
[ f ] [ "b" "[a-]" matches? ] unit-test [ f ] [ "b" "[a-]" f <regexp> matches? ] unit-test
[ f ] [ "-" "[^-]" matches? ] unit-test [ f ] [ "-" "[^-]" f <regexp> matches? ] unit-test
[ t ] [ "a" "[^-]" matches? ] unit-test [ t ] [ "a" "[^-]" f <regexp> matches? ] unit-test
[ f ] [ "-" "[a-c]" matches? ] unit-test [ f ] [ "-" "[a-c]" f <regexp> matches? ] unit-test
[ t ] [ "-" "[^a-c]" matches? ] unit-test [ t ] [ "-" "[^a-c]" f <regexp> matches? ] unit-test
[ t ] [ "b" "[a-c]" matches? ] unit-test [ t ] [ "b" "[a-c]" f <regexp> matches? ] unit-test
[ f ] [ "b" "[^a-c]" matches? ] unit-test [ f ] [ "b" "[^a-c]" f <regexp> matches? ] unit-test
[ t ] [ "-" "[a-c-]" matches? ] unit-test [ t ] [ "-" "[a-c-]" f <regexp> matches? ] unit-test
[ f ] [ "-" "[^a-c-]" matches? ] unit-test [ f ] [ "-" "[^a-c-]" f <regexp> matches? ] unit-test
[ t ] [ "\\" "[\\\\]" matches? ] unit-test [ t ] [ "\\" "[\\\\]" f <regexp> matches? ] unit-test
[ f ] [ "a" "[\\\\]" matches? ] unit-test [ f ] [ "a" "[\\\\]" f <regexp> matches? ] unit-test
[ f ] [ "\\" "[^\\\\]" matches? ] unit-test [ f ] [ "\\" "[^\\\\]" f <regexp> matches? ] unit-test
[ t ] [ "a" "[^\\\\]" matches? ] unit-test [ t ] [ "a" "[^\\\\]" f <regexp> matches? ] unit-test
[ t ] [ "0" "[\\d]" matches? ] unit-test [ t ] [ "0" "[\\d]" f <regexp> matches? ] unit-test
[ f ] [ "a" "[\\d]" matches? ] unit-test [ f ] [ "a" "[\\d]" f <regexp> matches? ] unit-test
[ f ] [ "0" "[^\\d]" matches? ] unit-test [ f ] [ "0" "[^\\d]" f <regexp> matches? ] unit-test
[ t ] [ "a" "[^\\d]" matches? ] unit-test [ t ] [ "a" "[^\\d]" f <regexp> matches? ] unit-test
[ t ] [ "a" "[a-z]{1,}|[A-Z]{2,4}|b*|c|(f|g)*" matches? ] unit-test [ t ] [ "a" "[a-z]{1,}|[A-Z]{2,4}|b*|c|(f|g)*" f <regexp> matches? ] unit-test
[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}|b*|c|(f|g)*" matches? ] unit-test [ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}|b*|c|(f|g)*" f <regexp> matches? ] unit-test
[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}" matches? ] unit-test [ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}" f <regexp> matches? ] unit-test
[ t ] [ "1000" "\\d{4,6}" matches? ] unit-test [ t ] [ "1000" "\\d{4,6}" f <regexp> matches? ] unit-test
[ t ] [ "1000" "[0-9]{4,6}" matches? ] unit-test [ t ] [ "1000" "[0-9]{4,6}" f <regexp> matches? ] unit-test
[ t ] [ "abc" "\\p{Lower}{3}" matches? ] unit-test [ t ] [ "abc" "\\p{Lower}{3}" f <regexp> matches? ] unit-test
[ f ] [ "ABC" "\\p{Lower}{3}" matches? ] unit-test [ f ] [ "ABC" "\\p{Lower}{3}" f <regexp> matches? ] unit-test
[ t ] [ "ABC" "\\p{Upper}{3}" matches? ] unit-test [ t ] [ "ABC" "\\p{Upper}{3}" f <regexp> matches? ] unit-test
[ f ] [ "abc" "\\p{Upper}{3}" matches? ] unit-test [ f ] [ "abc" "\\p{Upper}{3}" f <regexp> matches? ] unit-test
[ f ] [ "abc" "[\\p{Upper}]{3}" matches? ] unit-test [ f ] [ "abc" "[\\p{Upper}]{3}" f <regexp> matches? ] unit-test
[ t ] [ "ABC" "[\\p{Upper}]{3}" matches? ] unit-test [ t ] [ "ABC" "[\\p{Upper}]{3}" f <regexp> matches? ] unit-test
[ t ] [ "" "\\Q\\E" matches? ] unit-test [ t ] [ "" "\\Q\\E" f <regexp> matches? ] unit-test
[ f ] [ "a" "\\Q\\E" matches? ] unit-test [ f ] [ "a" "\\Q\\E" f <regexp> matches? ] unit-test
[ t ] [ "|*+" "\\Q|*+\\E" matches? ] unit-test [ t ] [ "|*+" "\\Q|*+\\E" f <regexp> matches? ] unit-test
[ f ] [ "abc" "\\Q|*+\\E" matches? ] unit-test [ f ] [ "abc" "\\Q|*+\\E" f <regexp> matches? ] unit-test
[ t ] [ "S" "\\0123" matches? ] unit-test [ t ] [ "S" "\\0123" f <regexp> matches? ] unit-test
[ t ] [ "SXY" "\\0123XY" matches? ] unit-test [ t ] [ "SXY" "\\0123XY" f <regexp> matches? ] unit-test
[ t ] [ "x" "\\x78" matches? ] unit-test [ t ] [ "x" "\\x78" f <regexp> matches? ] unit-test
[ f ] [ "y" "\\x78" matches? ] unit-test [ f ] [ "y" "\\x78" f <regexp> matches? ] unit-test
[ t ] [ "x" "\\u0078" matches? ] unit-test [ t ] [ "x" "\\u0078" f <regexp> matches? ] unit-test
[ f ] [ "y" "\\u0078" matches? ] unit-test [ f ] [ "y" "\\u0078" f <regexp> matches? ] unit-test
[ t ] [ "ab" "a+b" matches? ] unit-test [ t ] [ "ab" "a+b" f <regexp> matches? ] unit-test
[ f ] [ "b" "a+b" matches? ] unit-test [ f ] [ "b" "a+b" f <regexp> matches? ] unit-test
[ t ] [ "aab" "a+b" matches? ] unit-test [ t ] [ "aab" "a+b" f <regexp> matches? ] unit-test
[ f ] [ "abb" "a+b" matches? ] unit-test [ f ] [ "abb" "a+b" f <regexp> matches? ] unit-test
[ t ] [ "abbbb" "ab*" matches? ] unit-test [ t ] [ "abbbb" "ab*" f <regexp> matches? ] unit-test
[ t ] [ "a" "ab*" matches? ] unit-test [ t ] [ "a" "ab*" f <regexp> matches? ] unit-test
[ f ] [ "abab" "ab*" matches? ] unit-test [ f ] [ "abab" "ab*" f <regexp> matches? ] unit-test
[ f ] [ "x" "\\." matches? ] unit-test [ f ] [ "x" "\\." f <regexp> matches? ] unit-test
[ t ] [ "." "\\." matches? ] unit-test [ t ] [ "." "\\." f <regexp> matches? ] unit-test
[ t ] [ "aaaab" "a+ab" f <regexp> matches? ] unit-test
[ f ] [ "aaaxb" "a+ab" f <regexp> matches? ] unit-test
[ t ] [ "aaacb" "a+cb" f <regexp> matches? ] unit-test
[ f ] [ "aaaab" "a++ab" f <regexp> matches? ] unit-test
[ t ] [ "aaacb" "a++cb" f <regexp> matches? ] unit-test
[ 3 ] [ "aaacb" "a*" f <regexp> match-head ] unit-test
[ 1 ] [ "aaacb" "a+?" f <regexp> match-head ] unit-test
[ 2 ] [ "aaacb" "aa?" f <regexp> match-head ] unit-test
[ 1 ] [ "aaacb" "aa??" f <regexp> match-head ] unit-test
[ 3 ] [ "aacb" "aa?c" f <regexp> match-head ] unit-test
[ 3 ] [ "aacb" "aa??c" f <regexp> match-head ] unit-test
[ t ] [ "aaa" "AAA" t <regexp> matches? ] unit-test
[ f ] [ "aax" "AAA" t <regexp> matches? ] unit-test
[ t ] [ "aaa" "A*" t <regexp> matches? ] unit-test
[ f ] [ "aaba" "A*" t <regexp> matches? ] unit-test
[ t ] [ "b" "[AB]" t <regexp> matches? ] unit-test
[ f ] [ "c" "[AB]" t <regexp> matches? ] unit-test
[ t ] [ "c" "[A-Z]" t <regexp> matches? ] unit-test
[ f ] [ "3" "[A-Z]" t <regexp> matches? ] unit-test
[ ] [
"(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
] unit-test

168
extra/regexp/regexp.factor
View File

@ -1,15 +1,36 @@
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 macros promises quotations sequences combinators.lib strings
assocs prettyprint.backend ; assocs prettyprint.backend ;
USE: io USE: io
IN: regexp IN: regexp
<PRIVATE
SYMBOL: ignore-case?
: char=-quot ( ch -- quot )
ignore-case? get
[ ch>upper [ swap ch>upper = ] ] [ [ = ] ] if
curry ;
: char-between?-quot ( ch1 ch2 -- quot )
ignore-case? get
[ [ ch>upper ] 2apply [ >r >r ch>upper r> r> between? ] ]
[ [ between? ] ]
if 2curry ;
: or-predicates ( quots -- quot ) : or-predicates ( quots -- quot )
[ \ dup add* ] map [ [ t ] ] f short-circuit \ nip add ; [ \ dup add* ] map [ [ t ] ] f short-circuit \ nip add ;
MACRO: fast-member? ( str -- quot ) : <@literal [ nip ] curry <@ ;
[ dup ] H{ } map>assoc [ key? ] curry ;
: <@delay [ curry ] curry <@ ;
PRIVATE>
: ascii? ( n -- ? )
0 HEX: 7f between? ;
: octal-digit? ( n -- ? ) : octal-digit? ( n -- ? )
CHAR: 0 CHAR: 7 between? ; CHAR: 0 CHAR: 7 between? ;
@ -19,30 +40,32 @@ MACRO: fast-member? ( str -- quot )
: hex-digit? ( n -- ? ) : hex-digit? ( n -- ? )
dup decimal-digit? dup decimal-digit?
swap CHAR: a CHAR: f between? or ; over CHAR: a CHAR: f between? or
swap CHAR: A CHAR: F between? or ;
: control-char? ( n -- ? ) : control-char? ( n -- ? )
dup 0 HEX: 1f between? dup 0 HEX: 1f between?
swap HEX: 7f = or ; swap HEX: 7f = or ;
: punct? ( n -- ? ) : punct? ( n -- ? )
"!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" fast-member? ; "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ;
: c-identifier-char? ( ch -- ? ) : c-identifier-char? ( ch -- ? )
dup alpha? swap CHAR: _ = or ; dup alpha? swap CHAR: _ = or ;
: java-blank? ( n -- ? ) : java-blank? ( n -- ? )
{ {
CHAR: \s
CHAR: \t CHAR: \n CHAR: \r CHAR: \t CHAR: \n CHAR: \r
HEX: c HEX: 7 HEX: 1b HEX: c HEX: 7 HEX: 1b
} fast-member? ; } member? ;
: java-printable? ( n -- ? ) : java-printable? ( n -- ? )
dup alpha? swap punct? or ; dup alpha? swap punct? or ;
: 'ordinary-char' ( -- parser ) : 'ordinary-char' ( -- parser )
[ "\\^*+?|(){}[$" fast-member? not ] satisfy [ "\\^*+?|(){}[$" member? not ] satisfy
[ [ = ] curry ] <@ ; [ char=-quot ] <@ ;
: 'octal-digit' ( -- parser ) [ octal-digit? ] satisfy ; : 'octal-digit' ( -- parser ) [ octal-digit? ] satisfy ;
@ -58,7 +81,7 @@ MACRO: fast-member? ( str -- quot )
[ hex> ] <@ ; [ hex> ] <@ ;
: satisfy-tokens ( assoc -- parser ) : satisfy-tokens ( assoc -- parser )
[ >r token r> [ nip ] curry <@ ] { } assoc>map <or-parser> ; [ >r token r> <@literal ] { } assoc>map <or-parser> ;
: 'simple-escape-char' ( -- parser ) : 'simple-escape-char' ( -- parser )
{ {
@ -69,7 +92,7 @@ MACRO: fast-member? ( str -- quot )
{ "f" HEX: c } { "f" HEX: c }
{ "a" HEX: 7 } { "a" HEX: 7 }
{ "e" HEX: 1b } { "e" HEX: 1b }
} [ [ = ] curry ] assoc-map satisfy-tokens ; } [ char=-quot ] assoc-map satisfy-tokens ;
: 'predefined-char-class' ( -- parser ) : 'predefined-char-class' ( -- parser )
{ {
@ -85,7 +108,7 @@ MACRO: fast-member? ( str -- quot )
{ {
{ "Lower" [ letter? ] } { "Lower" [ letter? ] }
{ "Upper" [ LETTER? ] } { "Upper" [ LETTER? ] }
{ "ASCII" [ 0 HEX: 7f between? ] } { "ASCII" [ ascii? ] }
{ "Alpha" [ Letter? ] } { "Alpha" [ Letter? ] }
{ "Digit" [ digit? ] } { "Digit" [ digit? ] }
{ "Alnum" [ alpha? ] } { "Alnum" [ alpha? ] }
@ -103,7 +126,7 @@ MACRO: fast-member? ( str -- quot )
'hex' <|> 'hex' <|>
"c" token [ LETTER? ] satisfy &> <|> "c" token [ LETTER? ] satisfy &> <|>
any-char-parser <|> any-char-parser <|>
[ [ = ] curry ] <@ ; [ char=-quot ] <@ ;
: 'escape' ( -- parser ) : 'escape' ( -- parser )
"\\" token "\\" token
@ -113,7 +136,7 @@ MACRO: fast-member? ( str -- quot )
'simple-escape' <|> &> ; 'simple-escape' <|> &> ;
: 'any-char' : 'any-char'
"." token [ drop [ drop t ] ] <@ ; "." token [ drop t ] <@literal ;
: 'char' : 'char'
'any-char' 'escape' 'ordinary-char' <|> <|> [ satisfy ] <@ ; 'any-char' 'escape' 'ordinary-char' <|> <|> [ satisfy ] <@ ;
@ -124,21 +147,24 @@ TUPLE: group-result str ;
C: <group-result> group-result C: <group-result> group-result
: 'grouping' : 'non-capturing-group' ( -- parser )
'regexp' "(?:" ")" surrounded-by ;
: 'group' ( -- parser )
'regexp' [ [ <group-result> ] <@ ] <@ 'regexp' [ [ <group-result> ] <@ ] <@
"(" ")" surrounded-by ; "(" ")" surrounded-by ;
: 'range' ( -- parser ) : 'range' ( -- parser )
any-char-parser "-" token <& any-char-parser <&> any-char-parser "-" token <& any-char-parser <&>
[ first2 [ between? ] 2curry ] <@ ; [ first2 char-between?-quot ] <@ ;
: 'character-class-term' ( -- parser ) : 'character-class-term' ( -- parser )
'range' 'range'
'escape' <|> 'escape' <|>
[ "\\]" member? not ] satisfy [ [ = ] curry ] <@ <|> ; [ "\\]" member? not ] satisfy [ char=-quot ] <@ <|> ;
: 'positive-character-class' ( -- parser ) : 'positive-character-class' ( -- parser )
"]" token [ drop [ CHAR: ] = ] ] <@ 'character-class-term' <*> <&:> "]" token [ CHAR: ] = ] <@literal 'character-class-term' <*> <&:>
'character-class-term' <+> <|> 'character-class-term' <+> <|>
[ or-predicates ] <@ ; [ or-predicates ] <@ ;
@ -151,66 +177,101 @@ C: <group-result> group-result
"[" "]" surrounded-by [ satisfy ] <@ ; "[" "]" surrounded-by [ satisfy ] <@ ;
: 'escaped-seq' ( -- parser ) : 'escaped-seq' ( -- parser )
any-char-parser <*> [ token ] <@ "\\Q" "\\E" surrounded-by ; any-char-parser <*>
[ ignore-case? get <token-parser> ] <@
"\\Q" "\\E" surrounded-by ;
: 'simple' ( -- parser ) : 'simple' ( -- parser )
'escaped-seq' 'escaped-seq'
'grouping' <|> 'non-capturing-group' <|>
'group' <|>
'char' <|> 'char' <|>
'character-class' <|> ; 'character-class' <|> ;
: 'exactly-n' ( -- parser )
'integer' [ exactly-n ] <@delay ;
: 'at-least-n' ( -- parser )
'integer' "," token <& [ at-least-n ] <@delay ;
: 'at-most-n' ( -- parser )
"," token 'integer' &> [ at-most-n ] <@delay ;
: 'from-m-to-n' ( -- parser )
'integer' "," token <& 'integer' <&> [ first2 from-m-to-n ] <@delay ;
: 'greedy-interval' ( -- parser ) : 'greedy-interval' ( -- parser )
'simple' 'integer' "{" "}" surrounded-by <&> [ first2 exactly-n ] <@ 'exactly-n' 'at-least-n' <|> 'at-most-n' <|> 'from-m-to-n' <|> ;
'simple' 'integer' "{" ",}" surrounded-by <&> [ first2 at-least-n ] <@ <|>
'simple' 'integer' "{," "}" surrounded-by <&> [ first2 at-most-n ] <@ <|>
'simple' 'integer' "," token <& 'integer' <&> "{" "}" surrounded-by <&> [ first2 first2 from-m-to-n ] <@ <|> ;
: 'interval' ( -- parser ) : 'interval' ( -- parser )
'greedy-interval' 'greedy-interval'
'greedy-interval' "?" token <& [ "reluctant {}" print ] <@ <|> 'greedy-interval' "?" token <& [ "reluctant {}" print ] <@ <|>
'greedy-interval' "+" token <& [ "possessive {}" print ] <@ <|> ; 'greedy-interval' "+" token <& [ "possessive {}" print ] <@ <|>
"{" "}" surrounded-by ;
: 'greedy-repetition' ( -- parser )
'simple' "*" token <& [ <*> ] <@
'simple' "+" token <& [ <+> ] <@ <|>
'simple' "?" token <& [ <?> ] <@ <|> ;
: 'repetition' ( -- parser ) : 'repetition' ( -- parser )
'greedy-repetition' ! Posessive
'greedy-repetition' "?" token <& [ "reluctant" print ] <@ <|> "*+" token [ <!*> ] <@literal
'greedy-repetition' "+" token <& [ "possessive" print ] <@ <|> ; "++" token [ <!+> ] <@literal <|>
"?+" token [ <!?> ] <@literal <|>
! Reluctant
"*?" token [ <(*)> ] <@literal <|>
"+?" token [ <(+)> ] <@literal <|>
"??" token [ <(?)> ] <@literal <|>
! Greedy
"*" token [ <*> ] <@literal <|>
"+" token [ <+> ] <@literal <|>
"?" token [ <?> ] <@literal <|> ;
: 'dummy' ( -- parser )
epsilon [ ] <@literal ;
: 'term' ( -- parser ) : 'term' ( -- parser )
'simple' 'repetition' 'interval' <|> <|> 'simple'
<+> [ <and-parser> ] <@ ; 'repetition' 'interval' 'dummy' <|> <|> <&> [ first2 call ] <@
<!+> [ <and-parser> ] <@ ;
LAZY: 'regexp' ( -- parser ) LAZY: 'regexp' ( -- parser )
'term' "|" token nonempty-list-of [ <or-parser> ] <@ 'term' "|" token nonempty-list-of [ <or-parser> ] <@ ;
"^" token 'term' "|" token nonempty-list-of [ <or-parser> ] <@ ! "^" token 'term' "|" token nonempty-list-of [ <or-parser> ] <@
&> [ "caret" print ] <@ <|> ! &> [ "caret" print ] <@ <|>
'term' "|" token nonempty-list-of [ <or-parser> ] <@ ! 'term' "|" token nonempty-list-of [ <or-parser> ] <@
"$" token <& [ "dollar" print ] <@ <|> ! "$" token <& [ "dollar" print ] <@ <|>
"^" token 'term' "|" token nonempty-list-of [ <or-parser> ] <@ &> ! "^" token 'term' "|" token nonempty-list-of [ <or-parser> ] <@ &>
"$" token [ "caret dollar" print ] <@ <& <|> ; ! "$" token [ "caret dollar" print ] <@ <& <|> ;
TUPLE: regexp source parser ; TUPLE: regexp source parser ignore-case? ;
: <regexp> dup 'regexp' just parse-1 regexp construct-boa ; : <regexp> ( string ignore-case? -- regexp )
[
ignore-case? [
dup 'regexp' just parse-1
] with-variable
] keep regexp construct-boa ;
GENERIC: >regexp ( obj -- parser ) : do-ignore-case ( string regexp -- string regexp )
dup regexp-ignore-case? [ >r >upper r> ] when ;
M: string >regexp <regexp> ;
M: object >regexp ;
: matches? ( string regexp -- ? ) : matches? ( string regexp -- ? )
>regexp regexp-parser just parse nil? not ; do-ignore-case regexp-parser just parse nil? not ;
: match-head ( string regexp -- end )
do-ignore-case regexp-parser parse dup nil?
[ drop f ] [ car parse-result-unparsed slice-from ] if ;
! Literal syntax for regexps ! Literal syntax for regexps
: parse-options ( string -- ? )
#! Lame
{
{ "" [ f ] }
{ "i" [ t ] }
} case ;
: parse-regexp ( accum end -- accum ) : parse-regexp ( accum end -- accum )
lexer get dup skip-blank [ lexer get dup skip-blank [
[ index* dup 1+ swap ] 2keep swapd subseq swap [ index* dup 1+ swap ] 2keep swapd subseq swap
] change-column <regexp> parsed ; ] change-column
lexer get (parse-token) parse-options <regexp> parsed ;
: R! CHAR: ! parse-regexp ; parsing : R! CHAR: ! parse-regexp ; parsing
: R" CHAR: " parse-regexp ; parsing : R" CHAR: " parse-regexp ; parsing
@ -240,4 +301,9 @@ M: object >regexp ;
} swap [ subseq? not nip ] curry assoc-find drop ; } swap [ subseq? not nip ] curry assoc-find drop ;
M: regexp pprint* M: regexp pprint*
dup regexp-source dup find-regexp-syntax pprint-string ; [
dup regexp-source
dup find-regexp-syntax swap % swap % %
dup regexp-ignore-case? [ "i" % ] when
] "" make
swap present-text ;

7
extra/rss/rss.factor
View File

@ -88,12 +88,15 @@ C: <entry> entry
: simple-tag, ( content name -- ) : simple-tag, ( content name -- )
[ , ] tag, ; [ , ] tag, ;
: simple-tag*, ( content name attrs -- )
[ , ] tag*, ;
: entry, ( entry -- ) : entry, ( entry -- )
"entry" [ "entry" [
dup entry-title "title" simple-tag, dup entry-title "title" { { "type" "html" } } simple-tag*,
"link" over entry-link "href" associate contained*, "link" over entry-link "href" associate contained*,
dup entry-pub-date "published" simple-tag, dup entry-pub-date "published" simple-tag,
entry-description [ "content" simple-tag, ] when* entry-description [ "content" { { "type" "html" } } simple-tag*, ] when*
] tag, ; ] tag, ;
: feed>xml ( feed -- xml ) : feed>xml ( feed -- xml )

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

@ -4,8 +4,8 @@ USING: alien alien.c-types arrays assocs ui ui.gadgets
ui.backend ui.clipboards ui.gadgets.worlds ui.gestures io kernel ui.backend ui.clipboards ui.gadgets.worlds ui.gestures io kernel
math math.vectors namespaces prettyprint sequences strings math math.vectors namespaces prettyprint sequences strings
vectors words windows.kernel32 windows.gdi32 windows.user32 vectors words windows.kernel32 windows.gdi32 windows.user32
windows.opengl32 windows.messages windows.types windows.nt windows.opengl32 windows.messages windows.types
windows threads timers libc combinators continuations windows.nt windows threads timers libc combinators continuations
command-line shuffle opengl ui.render ; command-line shuffle opengl ui.render ;
IN: ui.windows IN: ui.windows
@ -257,14 +257,12 @@ M: windows-ui-backend (close-window)
: prepare-mouse ( hWnd uMsg wParam lParam -- button coordinate world ) : prepare-mouse ( hWnd uMsg wParam lParam -- button coordinate world )
nip >r mouse-event>gesture r> >lo-hi rot window ; nip >r mouse-event>gesture r> >lo-hi rot window ;
: mouse-captured? ( -- ? )
mouse-captured get ;
: set-capture ( hwnd -- ) : set-capture ( hwnd -- )
mouse-captured get [ mouse-captured get [
drop drop
] [ ] [
[ SetCapture drop ] keep mouse-captured set [ SetCapture drop ] keep
mouse-captured set
] if ; ] if ;
: release-capture ( -- ) : release-capture ( -- )
@ -276,7 +274,7 @@ M: windows-ui-backend (close-window)
prepare-mouse send-button-down ; prepare-mouse send-button-down ;
: handle-wm-buttonup ( hWnd uMsg wParam lParam -- ) : handle-wm-buttonup ( hWnd uMsg wParam lParam -- )
mouse-captured? [ release-capture ] when mouse-captured get [ release-capture ] when
prepare-mouse send-button-up ; prepare-mouse send-button-up ;
: make-TRACKMOUSEEVENT ( hWnd -- alien ) : make-TRACKMOUSEEVENT ( hWnd -- alien )
@ -434,7 +432,7 @@ M: windows-ui-backend flush-gl-context ( handle -- )
! Move window to front ! Move window to front
M: windows-ui-backend raise-window ( world -- ) M: windows-ui-backend raise-window ( world -- )
world-handle [ world-handle [
win-hWnd SetFocus drop release-capture win-hWnd SetFocus drop
] when* ; ] when* ;
M: windows-ui-backend set-title ( string world -- ) M: windows-ui-backend set-title ( string world -- )

7
extra/webapps/article-manager/article-manager.factor
View File

@ -4,12 +4,17 @@
USING: kernel furnace sqlite.tuple-db webapps.article-manager.database USING: kernel furnace sqlite.tuple-db webapps.article-manager.database
sequences namespaces math arrays assocs quotations io.files sequences namespaces math arrays assocs quotations io.files
http.server http.basic-authentication http.server.responders http.server http.basic-authentication http.server.responders
webapps.file ; webapps.file html html.elements io ;
IN: webapps.article-manager IN: webapps.article-manager
: current-site ( -- site ) : current-site ( -- site )
host get-site* ; host get-site* ;
: render-titled-page* ( model body-template head-template title -- )
[
[ render-component ] swap [ <title> write </title> f rot render-component ] curry html-document
] serve-html ;
TUPLE: template-args arg1 ; TUPLE: template-args arg1 ;
C: <template-args> template-args C: <template-args> template-args

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

@ -1,12 +1,12 @@
<% USING: kernel io http.server namespaces sequences math html.elements random furnace webapps.article-manager webapps.article-manager.database html.elements ; %> <% 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> <div id="banner"><h1><% "arg1" get second article-title write %></h1></div>
<% f "navigation" render-template %> <% "navigation" render-template %>
<div id="article"> <div id="article">
<% 100 random 25 > [ "arg1" get first 100 random 50 > [ site-ad2 ] [ site-ad3 ] if write-html ] when %> <% 100 random 25 > [ "arg1" get first 100 random 50 > [ site-ad2 ] [ site-ad3 ] if write-html ] when %>
<% "arg1" get second article-body write-html %> <% "arg1" get second article-body write-html %>
<h1>Tags</h1> <h1>Tags</h1>
<% "arg1" get second tags-for-article <template-args> "tags" render-template %> <% "arg1" get second tags-for-article <template-args> "tags" render-component %>
</div> </div>
<p class="footer"></p> <p class="footer"></p>
<p id="copyright"><% "arg1" get first site-footer write %></p> <p id="copyright"><% "arg1" get first site-footer write %></p>

4
extra/webapps/article-manager/furnace/index.furnace
View File

@ -6,7 +6,7 @@
</head> </head>
<body> <body>
<div id="banner"><h1><% "title" get write %></h1></div> <div id="banner"><h1><% "title" get write %></h1></div>
<% f "navigation" render-template %> <% "navigation" render-template %>
<div id="article"> <div id="article">
<% "intro" get write-html %> <% "intro" get write-html %>
<h1>Recent Articles</h1> <h1>Recent Articles</h1>
@ -23,7 +23,7 @@
but in the meantime, Google is likely to provide but in the meantime, Google is likely to provide
reasonable results. reasonable results.
</p> </p>
<% host all-tags <template-args> "tags" render-template %> <% host all-tags <template-args> "tags" render-component %>
</div> </div>
<p class="footer"></p> <p class="footer"></p>
<p id="copyright"><% "footer" get write %></p> <p id="copyright"><% "footer" get write %></p>

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

@ -5,5 +5,5 @@
</ul> </ul>
<% current-site site-ad1 write-html %> <% current-site site-ad1 write-html %>
<h1>Tags</h1> <h1>Tags</h1>
<% host all-tags <template-args> "tags" render-template %> <% host all-tags <template-args> "tags" render-component %>
</div> </div>

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

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

22
extra/webapps/file/file.factor Normal file → Executable file
View File

@ -1,4 +1,4 @@
! Copyright (C) 2004, 2006 Slava Pestov. ! Copyright (C) 2004, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: calendar html io io.files kernel math math.parser USING: calendar html io io.files kernel math math.parser
http.server.responders http.server.templating namespaces parser http.server.responders http.server.templating namespaces parser
@ -31,15 +31,23 @@ IN: webapps.file
"304 Not Modified" response "304 Not Modified" response
now timestamp>http-string "Date" associate print-header ; now timestamp>http-string "Date" associate print-header ;
! You can override how files are served in a custom responder
SYMBOL: serve-file-hook
[
file-response
stdio get stream-copy
] serve-file-hook set-global
: serve-static ( filename mime-type -- ) : serve-static ( filename mime-type -- )
over last-modified-matches? [ over last-modified-matches? [
2drop not-modified-response 2drop not-modified-response
] [ ] [
dupd file-response
"method" get "head" = [ "method" get "head" = [
drop file-response
] [ ] [
<file-reader> stdio get stream-copy >r dup <file-reader> swap r>
serve-file-hook get call
] if ] if
] if ; ] if ;
@ -53,9 +61,13 @@ SYMBOL: page
: include-page ( filename -- ) : include-page ( filename -- )
"doc-root" get swap path+ run-page ; "doc-root" get swap path+ run-page ;
: serve-fhtml ( filename -- )
serving-html
"method" get "head" = [ drop ] [ run-page ] if ;
: serve-file ( filename -- ) : serve-file ( filename -- )
dup mime-type dup "application/x-factor-server-page" = dup mime-type dup "application/x-factor-server-page" =
[ drop serving-html run-page ] [ serve-static ] if ; [ drop serve-fhtml ] [ serve-static ] if ;
: file. ( name dirp -- ) : file. ( name dirp -- )
[ "/" append ] when [ "/" append ] when

7
extra/webapps/fjsc/fjsc.factor
View File

@ -4,7 +4,7 @@
USING: kernel furnace fjsc parser-combinators namespaces USING: kernel furnace fjsc parser-combinators namespaces
lazy-lists io io.files furnace.validator sequences lazy-lists io io.files furnace.validator sequences
http.client http.server http.server.responders http.client http.server http.server.responders
webapps.file ; webapps.file html ;
IN: webapps.fjsc IN: webapps.fjsc
: compile ( code -- ) : compile ( code -- )
@ -31,6 +31,11 @@ IN: webapps.fjsc
{ "url" v-required } { "url" v-required }
} define-action } define-action
: render-page* ( model body-template head-template -- )
[
[ render-component ] [ f rot render-component ] html-document
] serve-html ;
: repl ( -- ) : repl ( -- )
#! The main 'repl' page. #! The main 'repl' page.
f "repl" "head" render-page* ; f "repl" "head" render-page* ;

2
extra/webapps/help/help.factor
View File

@ -82,4 +82,4 @@ PREDICATE: pathname resource-pathname
M: resource-pathname browser-link-href M: resource-pathname browser-link-href
pathname-string pathname-string
"resource:" ?head drop "resource:" ?head drop
"/responder/resources/" swap append ; "/responder/source/" swap append ;

21
extra/webapps/pastebin/annotate-paste.furnace Normal file → Executable file
View File

@ -1,4 +1,4 @@
<% USING: io math math.parser namespaces ; %> <% USING: io math math.parser namespaces furnace ; %>
<h1>Annotate</h1> <h1>Annotate</h1>
@ -9,17 +9,22 @@
<input type="hidden" name="n" value="<% "n" get number>string write %>" /> <input type="hidden" name="n" value="<% "n" get number>string write %>" />
<tr> <tr>
<th>Your name:</th> <th align="right">Summary:</th>
<td><input type="TEXT" name="author" value="" /></td>
</tr>
<tr>
<th>Summary:</th>
<td><input type="TEXT" name="summary" value="" /></td> <td><input type="TEXT" name="summary" value="" /></td>
</tr> </tr>
<tr> <tr>
<th valign="top">Contents:</th> <th align="right">Your name:</th>
<td><input type="TEXT" name="author" value="" /></td>
</tr>
<tr>
<th align="right">File type:</th>
<td><% "modes" render-template %></td>
</tr>
<tr>
<th align="right" valign="top">Content:</th>
<td><textarea rows="24" cols="60" name="contents"></textarea></td> <td><textarea rows="24" cols="60" name="contents"></textarea></td>
</tr> </tr>
</table> </table>

6
extra/webapps/pastebin/annotation.furnace Normal file → Executable file
View File

@ -1,11 +1,11 @@
<% USING: namespaces io ; %> <% USING: namespaces io furnace calendar ; %>
<h2>Annotation: <% "summary" get write %></h2> <h2>Annotation: <% "summary" get write %></h2>
<table> <table>
<tr><th>Annotation by:</th><td><% "author" get write %></td></tr> <tr><th>Annotation 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 write %></td></tr> <tr><th>Created:</th><td><% "date" get timestamp>string write %></td></tr>
</table> </table>
<pre><% "contents" get write %></pre> <% "syntax" render-template %>

3
extra/webapps/pastebin/footer.furnace Normal file
View File

@ -0,0 +1,3 @@
</body>
</html>

23
extra/webapps/pastebin/header.furnace Normal file
View File

@ -0,0 +1,23 @@
<% USING: namespaces io furnace sequences xmode.code2html webapps.pastebin ; %>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml">
<head>
<meta http-equiv="Content-type" content="text/html; charset=utf-8" />
<title><% "title" get write %></title>
<link rel="stylesheet" href="style.css" type="text/css" media="screen" title="no title" charset="utf-8" />
<% default-stylesheet %>
<link rel="alternate" type="application/atom+xml" title="Pastebin - Atom" href="feed.xml" />
</head>
<body id="index">
<div class="navbar">
<% [ paste-list ] "Paste list" render-link %> |
<% [ new-paste ] "New paste" render-link %> |
<% [ feed.xml ] "Syndicate" render-link %>
</div>
<h1 class="pastebin-title"><% "title" get write %></h1>

7
extra/webapps/pastebin/modes.furnace Normal file
View File

@ -0,0 +1,7 @@
<% USING: xmode.catalog sequences kernel html.elements assocs io sorting ; %>
<select name="mode">
<% modes keys natural-sort [
<option dup "factor" = [ "true" =selected ] when option> write </option>
] each %>
</select>

30
extra/webapps/pastebin/new-paste.furnace Normal file → Executable file
View File

@ -1,27 +1,41 @@
<% USING: furnace namespaces ; %>
<%
"New paste" "title" set
"header" render-template
%>
<form method="POST" action="/responder/pastebin/submit-paste"> <form method="POST" action="/responder/pastebin/submit-paste">
<table> <table>
<tr> <tr>
<th>Your name:</th> <th align="right">Summary:</th>
<td><input type="TEXT" name="author" value="" /></td>
</tr>
<tr>
<th>Summary:</th>
<td><input type="TEXT" name="summary" value="" /></td> <td><input type="TEXT" name="summary" value="" /></td>
</tr> </tr>
<tr> <tr>
<th>Channel:</th> <th align="right">Your name:</th>
<td><input type="TEXT" name="author" value="" /></td>
</tr>
<tr>
<th align="right">File type:</th>
<td><% "modes" render-template %></td>
</tr>
<tr>
<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 valign="top">Contents:</th> <th align="right" valign="top">Content:</th>
<td><textarea rows="24" cols="60" name="contents"></textarea></td> <td><textarea rows="24" cols="60" name="contents"></textarea></td>
</tr> </tr>
</table> </table>
<input type="SUBMIT" value="Submit paste" /> <input type="SUBMIT" value="Submit paste" />
</form> </form>
<% "footer" render-template %>

32
extra/webapps/pastebin/paste-list.furnace
View File

@ -1,7 +1,31 @@
<% USING: namespaces furnace sequences ; %> <% USING: namespaces furnace sequences ; %>
<table width="100%"> <%
<% "new-paste-quot" get "New paste" render-link %> "Pastebin" "title" set
<tr align="left"><th>&nbsp;</th><th>Summary:</th><th>Paste by:</th><th>Link</th><th>Date</th></tr> "header" render-template
<% "pastes" get <reversed> [ "paste-summary" render-template ] each %></table> %>
<table width="100%" cellspacing="10">
<tr>
<td valign="top">
<table width="100%">
<tr align="left" class="pastebin-headings">
<th width="50%">Summary:</th>
<th width="100">Paste by:</th>
<th width="200">Date:</th>
</tr>
<% "pastes" get <reversed> [ "paste-summary" render-component ] each %>
</table>
</td>
<td valign="top" width="25%" class="infobox">
<p>This pastebin is written in <a href="http://factorcode.org/">Factor</a>. It is inspired by <a href="http://paste.lisp.org">lisppaste</a>.
</p>
<p>It can be used for collaborative development over IRC. You can post code for review, and annotate other people's code. Syntax highlighting for over a hundred file types is supported.
</p>
<p>
<% "webapps.pastebin" browse-webapp-source %></p>
</td>
</tr>
</table>
<% "footer" render-template %>

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

@ -1,9 +1,16 @@
<% USING: continuations namespaces io kernel math math.parser furnace ; %> <% USING: continuations namespaces io kernel math math.parser
furnace webapps.pastebin calendar sequences ; %>
<tr> <tr>
<td><% "n" get number>string write %></td> <td>
<td><% "summary" get write %></td> <a href="<% model get paste-link write %>">
<%
"summary" get
dup empty? [ drop "- no title -" ] when
write
%>
</a>
</td>
<td><% "author" get write %></td> <td><% "author" get write %></td>
<td><% "n" get number>string "show-paste-quot" get curry "Show" render-link %></td> <td><% "date" get timestamp>string print %></td>
<td><% "date" get print %></td>
</tr> </tr>

77
extra/webapps/pastebin/pastebin.factor Normal file → Executable file
View File

@ -1,5 +1,6 @@
USING: calendar furnace furnace.validator io.files kernel namespaces USING: calendar furnace furnace.validator io.files kernel
sequences store ; namespaces sequences store http.server.responders html
math.parser rss xml.writer ;
IN: webapps.pastebin IN: webapps.pastebin
TUPLE: pastebin pastes ; TUPLE: pastebin pastes ;
@ -7,23 +8,17 @@ TUPLE: pastebin pastes ;
: <pastebin> ( -- pastebin ) : <pastebin> ( -- pastebin )
V{ } clone pastebin construct-boa ; V{ } clone pastebin construct-boa ;
TUPLE: paste n summary article author channel contents date annotations ; TUPLE: paste
summary author channel mode contents date
annotations n ;
: <paste> ( summary author channel contents -- paste ) : <paste> ( summary author channel mode contents -- paste )
V{ } clone f V{ } clone f paste construct-boa ;
{
set-paste-summary
set-paste-author
set-paste-channel
set-paste-contents
set-paste-annotations
} paste construct ;
TUPLE: annotation summary author contents ; TUPLE: annotation summary author mode contents ;
C: <annotation> annotation C: <annotation> annotation
SYMBOL: store SYMBOL: store
"pastebin.store" resource-path load-store store set-global "pastebin.store" resource-path load-store store set-global
@ -34,49 +29,70 @@ SYMBOL: store
pastebin get pastebin-pastes nth ; pastebin get pastebin-pastes nth ;
: show-paste ( n -- ) : show-paste ( n -- )
get-paste "show-paste" "Paste" render-page ; serving-html
get-paste
[ "show-paste" render-component ] with-html-stream ;
\ show-paste { { "n" v-number } } define-action \ show-paste { { "n" v-number } } define-action
: new-paste ( -- ) : new-paste ( -- )
f "new-paste" "New paste" render-page ; serving-html
[ "new-paste" render-template ] with-html-stream ;
\ new-paste { } define-action \ new-paste { } define-action
: paste-list ( -- ) : paste-list ( -- )
serving-html
[ [
[ show-paste ] "show-paste-quot" set [ show-paste ] "show-paste-quot" set
[ new-paste ] "new-paste-quot" set [ new-paste ] "new-paste-quot" set
pastebin get "paste-list" "Pastebin" render-page pastebin get "paste-list" render-component
] with-scope ; ] with-html-stream ;
\ paste-list { } define-action \ paste-list { } define-action
: paste-link ( paste -- link )
paste-n number>string [ show-paste ] curry quot-link ;
: paste-feed ( -- entries )
pastebin get pastebin-pastes [
{
paste-summary
paste-link
paste-date
} get-slots timestamp>rfc3339 f swap <entry>
] map ;
: feed.xml ( -- )
"text/xml" serving-content
"pastebin"
"http://pastebin.factorcode.org"
paste-feed <feed> feed>xml write-xml ;
\ feed.xml { } define-action
: save-pastebin-store ( -- ) : save-pastebin-store ( -- )
store get-global save-store ; store get-global save-store ;
: add-paste ( paste pastebin -- ) : add-paste ( paste pastebin -- )
>r now timestamp>http-string over set-paste-date r> >r now over set-paste-date r>
pastebin-pastes pastebin-pastes 2dup length swap set-paste-n push ;
[ length over set-paste-n ] keep push ;
: submit-paste ( summary author channel contents -- ) : submit-paste ( summary author channel mode contents -- )
<paste> <paste> [
\ pastebin get-global add-paste \ pastebin get-global add-paste
save-pastebin-store ; save-pastebin-store
] keep paste-link permanent-redirect ;
\ submit-paste { \ submit-paste {
{ "summary" v-required } { "summary" v-required }
{ "author" v-required } { "author" v-required }
{ "channel" "#concatenative" v-default } { "channel" "#concatenative" v-default }
{ "mode" "factor" v-default }
{ "contents" v-required } { "contents" v-required }
} define-action } define-action
\ submit-paste [ paste-list ] define-redirect : annotate-paste ( n summary author mode contents -- )
: annotate-paste ( n summary author contents -- )
<annotation> swap get-paste <annotation> swap get-paste
paste-annotations push paste-annotations push
save-pastebin-store ; save-pastebin-store ;
@ -85,9 +101,16 @@ SYMBOL: store
{ "n" v-required v-number } { "n" v-required v-number }
{ "summary" v-required } { "summary" v-required }
{ "author" v-required } { "author" v-required }
{ "mode" "factor" v-default }
{ "contents" v-required } { "contents" v-required }
} define-action } define-action
\ annotate-paste [ "n" show-paste ] define-redirect \ annotate-paste [ "n" show-paste ] define-redirect
: style.css ( -- )
"text/css" serving-content
"style.css" send-resource ;
\ style.css { } define-action
"pastebin" "paste-list" "extra/webapps/pastebin" web-app "pastebin" "paste-list" "extra/webapps/pastebin" web-app

18
extra/webapps/pastebin/show-paste.furnace Normal file → Executable file
View File

@ -1,15 +1,21 @@
<% USING: namespaces io furnace sequences ; %> <% USING: namespaces io furnace sequences xmode.code2html calendar ; %>
<h1>Paste: <% "summary" get write %></h1> <%
"Paste: " "summary" get append "title" set
"header" render-template
%>
<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 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>
</table> </table>
<pre><% "contents" get write %></pre> <% "syntax" render-template %>
<% "annotations" get [ "annotation" render-template ] each %> <% "annotations" get [ "annotation" render-component ] each %>
<% model get "annotate-paste" render-template %> <% model get "annotate-paste" render-component %>
<% "footer" render-template %>

37
extra/webapps/pastebin/style.css Normal file
View File

@ -0,0 +1,37 @@
body {
font:75%/1.6em "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
color:#888;
}
h1.pastebin-title {
font-size:300%;
}
a {
color:#222;
border-bottom:1px dotted #ccc;
text-decoration:none;
}
a:hover {
border-bottom:1px solid #ccc;
}
pre.code {
border:1px dashed #ccc;
background-color:#f5f5f5;
padding:5px;
font-size:150%;
color:#000000;
}
.navbar {
background-color:#eeeeee;
padding:5px;
border:1px solid #ccc;
}
.infobox {
border: 1px solid #C1DAD7;
padding: 10px;
}

3
extra/webapps/pastebin/syntax.furnace Executable file
View File

@ -0,0 +1,3 @@
<% USING: xmode.code2html splitting namespaces ; %>
<pre class="code"><% "contents" get string-lines "mode" get htmlize-lines %></pre>

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

@ -1,41 +1,14 @@
USING: sequences rss arrays concurrency kernel sorting USING: sequences rss arrays concurrency kernel sorting
html.elements io assocs namespaces math threads vocabs html html.elements io assocs namespaces math threads vocabs html
furnace http.server.templating calendar math.parser splitting furnace http.server.templating calendar math.parser splitting
continuations debugger system http.server.responders ; continuations debugger system http.server.responders
xml.writer ;
IN: webapps.planet IN: webapps.planet
TUPLE: posting author title date link body ;
: diagnostic write print flush ;
: fetch-feed ( pair -- feed )
second
dup "Fetching " diagnostic
dup download-feed feed-entries
swap "Done fetching " diagnostic ;
: fetch-blogroll ( blogroll -- entries )
#! entries is an array of { author entries } pairs.
dup [
[ fetch-feed ] [ error. drop f ] recover
] parallel-map
[ [ >r first r> 2array ] curry* map ] 2map concat ;
: sort-entries ( entries -- entries' )
[ [ second entry-pub-date ] compare ] sort <reversed> ;
: <posting> ( pair -- posting )
#! pair has shape { author entry }
first2
{ entry-title entry-pub-date entry-link entry-description }
get-slots posting construct-boa ;
: print-posting-summary ( posting -- ) : print-posting-summary ( posting -- )
<p "news" =class p> <p "news" =class p>
<b> dup posting-title write </b> <br/> <b> dup entry-title write </b> <br/>
"- " write <a entry-link =href "more" =class a>
dup posting-author write bl
<a posting-link =href "more" =class a>
"Read More..." write "Read More..." write
</a> </a>
</p> ; </p> ;
@ -51,70 +24,86 @@ TUPLE: posting author title date link body ;
</ul> ; </ul> ;
: format-date ( date -- string ) : format-date ( date -- string )
10 head "-" split [ string>number ] map rfc3339>timestamp timestamp>string ;
first3 0 0 0 0 <timestamp>
[
dup timestamp-day #
" " %
dup timestamp-month month-abbreviations nth %
", " %
timestamp-year #
] "" make ;
: print-posting ( posting -- ) : print-posting ( posting -- )
<h2 "posting-title" =class h2> <h2 "posting-title" =class h2>
<a dup posting-link =href a> <a dup entry-link =href a>
dup posting-title write-html dup entry-title write-html
" - " write
dup posting-author write
</a> </a>
</h2> </h2>
<p "posting-body" =class p> dup posting-body write-html </p> <p "posting-body" =class p>
<p "posting-date" =class p> posting-date format-date write </p> ; dup entry-description write-html
</p>
<p "posting-date" =class p>
entry-pub-date format-date write
</p> ;
: print-postings ( postings -- ) : print-postings ( postings -- )
[ print-posting ] each ; [ print-posting ] each ;
: browse-webapp-source ( vocab -- )
<a f >vocab-link browser-link-href =href a>
"Browse source" write
</a> ;
SYMBOL: default-blogroll SYMBOL: default-blogroll
SYMBOL: cached-postings SYMBOL: cached-postings
: update-cached-postings ( -- ) : safe-head ( seq n -- seq' )
default-blogroll get fetch-blogroll sort-entries over length min head ;
[ <posting> ] map
cached-postings set-global ;
: mini-planet-factor ( -- ) : mini-planet-factor ( -- )
cached-postings get 4 head print-posting-summaries ; cached-postings get 4 safe-head print-posting-summaries ;
: planet-factor ( -- ) : planet-factor ( -- )
serving-html [ serving-html [ "planet" render-template ] with-html-stream ;
"resource:extra/webapps/planet/planet.fhtml"
run-template-file
] with-html-stream ;
\ planet-factor { } define-action \ planet-factor { } define-action
{ : planet-feed ( -- feed )
{ "Berlin Brown" "http://factorlang-fornovices.blogspot.com/feeds/posts/default" "http://factorlang-fornovices.blogspot.com" } "[ planet-factor ]"
{ "Chris Double" "http://www.bluishcoder.co.nz/atom.xml" "http://www.bluishcoder.co.nz/" } "http://planet.factorcode.org"
{ "Elie Chaftari" "http://fun-factor.blogspot.com/feeds/posts/default" "http://fun-factor.blogspot.com/" } cached-postings get 30 safe-head <feed> ;
{ "Doug Coleman" "http://code-factor.blogspot.com/feeds/posts/default" "http://code-factor.blogspot.com/" }
{ "Daniel Ehrenberg" "http://useless-factor.blogspot.com/feeds/posts/default" "http://useless-factor.blogspot.com/" } : feed.xml ( -- )
{ "Kio M. Smallwood" "text/xml" serving-content
"http://sekenre.wordpress.com/feed/atom/" planet-feed feed>xml write-xml ;
"http://sekenre.wordpress.com/" }
{ "Phil Dawes" "http://www.phildawes.net/blog/category/factor/feed/atom" "http://www.phildawes.net/blog/" } \ feed.xml { } define-action
{ "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/" } : style.css ( -- )
} default-blogroll set-global "text/css" serving-content
"style.css" send-resource ;
\ style.css { } define-action
SYMBOL: last-update SYMBOL: last-update
: diagnostic write print flush ;
: fetch-feed ( triple -- feed )
second
dup "Fetching " diagnostic
dup download-feed feed-entries
swap "Done fetching " diagnostic ;
: <posting> ( author entry -- entry' )
clone
[ ": " swap entry-title 3append ] keep
[ set-entry-title ] keep ;
: ?fetch-feed ( triple -- feed/f )
[ fetch-feed ] [ error. drop f ] recover ;
: fetch-blogroll ( blogroll -- entries )
dup 0 <column>
swap [ ?fetch-feed ] parallel-map
[ [ <posting> ] curry* map ] 2map concat ;
: sort-entries ( entries -- entries' )
[ [ entry-pub-date ] compare ] sort <reversed> ;
: update-cached-postings ( -- )
default-blogroll get
fetch-blogroll sort-entries
cached-postings set-global ;
: update-thread ( -- ) : update-thread ( -- )
millis last-update set-global millis last-update set-global
[ update-cached-postings ] in-thread [ update-cached-postings ] in-thread
@ -126,14 +115,17 @@ SYMBOL: last-update
"planet" "planet-factor" "extra/webapps/planet" web-app "planet" "planet-factor" "extra/webapps/planet" web-app
: merge-feeds ( feeds -- feed ) {
[ feed-entries ] map concat sort-entries ; { "Berlin Brown" "http://factorlang-fornovices.blogspot.com/feeds/posts/default" "http://factorlang-fornovices.blogspot.com" }
{ "Chris Double" "http://www.blogger.com/feeds/18561009/posts/full/-/factor" "http://www.bluishcoder.co.nz/" }
: planet-feed ( -- feed ) { "Elie Chaftari" "http://fun-factor.blogspot.com/feeds/posts/default" "http://fun-factor.blogspot.com/" }
default-blogroll get [ second download-feed ] map merge-feeds { "Doug Coleman" "http://code-factor.blogspot.com/feeds/posts/default" "http://code-factor.blogspot.com/" }
>r "[ planet-factor ]" "http://planet.factorcode.org" r> <entry> { "Daniel Ehrenberg" "http://useless-factor.blogspot.com/feeds/posts/default" "http://useless-factor.blogspot.com/" }
feed>xml ; { "Gavin Harrison" "http://gmh33.blogspot.com/feeds/posts/default" "http://gmh33.blogspot.com/" }
{ "Kio M. Smallwood"
: feed.xml planet-feed ; "http://sekenre.wordpress.com/feed/atom/"
"http://sekenre.wordpress.com/" }
\ feed.xml { } define-action { "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

14
extra/webapps/planet/planet.fhtml → extra/webapps/planet/planet.furnace
View File

@ -1,4 +1,5 @@
<% USING: namespaces html.elements webapps.planet sequences ; %> <% USING: namespaces html.elements webapps.planet sequences
furnace ; %>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
@ -8,14 +9,15 @@
<meta http-equiv="Content-type" content="text/html; charset=utf-8" /> <meta http-equiv="Content-type" content="text/html; charset=utf-8" />
<title>planet-factor</title> <title>planet-factor</title>
<link rel="stylesheet" href="/responder/file/css/news.css" type="text/css" media="screen" title="no title" charset="utf-8" /> <link rel="stylesheet" href="style.css" type="text/css" media="screen" title="no title" charset="utf-8" />
<link rel="alternate" type="application/atom+xml" title="Planet Factor - Atom" href="feed.xml" />
</head> </head>
<body id="index"> <body id="index">
<h1 class="planet-title">[ planet-factor ]</h1> <h1 class="planet-title">[ planet-factor ]</h1>
<table width="100%" cellpadding="10"> <table width="100%" cellpadding="10">
<tr> <tr>
<td> <% cached-postings get 20 head print-postings %> </td> <td> <% cached-postings get 20 safe-head print-postings %> </td>
<td valign="top" width="25%" class="infobox"> <td valign="top" width="25%" class="infobox">
<p> <p>
<b>planet-factor</b> is an Atom/RSS aggregator that collects the <b>planet-factor</b> is an Atom/RSS aggregator that collects the
@ -23,7 +25,11 @@
<a href="http://planet.lisp.org">Planet Lisp</a>. <a href="http://planet.lisp.org">Planet Lisp</a>.
</p> </p>
<p> <p>
This webapp is written in <a href="http://factorcode.org/">Factor</a>. <img src="http://planet.lisp.org/feed-icon-14x14.png" />
<a href="feed.xml"> Syndicate </a>
</p>
<p>
This webapp is written in <a href="http://factorcode.org/">Factor</a>.<br/>
<% "webapps.planet" browse-webapp-source %> <% "webapps.planet" browse-webapp-source %>
</p> </p>
<h2 class="blogroll-title">Blogroll</h2> <h2 class="blogroll-title">Blogroll</h2>

45
extra/webapps/planet/style.css Normal file
View File

@ -0,0 +1,45 @@
body {
font:75%/1.6em "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
color:#888;
}
h1.planet-title {
font-size:300%;
}
a {
color:#222;
border-bottom:1px dotted #ccc;
text-decoration:none;
}
a:hover {
border-bottom:1px solid #ccc;
}
.posting-title {
background-color:#f5f5f5;
}
pre, code {
color:#000000;
font-size:120%;
}
.infobox {
border-left: 1px solid #C1DAD7;
}
.posting-date {
text-align: right;
font-size:90%;
}
a.more {
display:block;
padding:0 0 5px 0;
color:#333;
text-decoration:none;
text-align:right;
border:none;
}

20
extra/webapps/source/source.factor Executable file
View File

@ -0,0 +1,20 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files namespaces webapps.file http.server.responders
xmode.code2html kernel html ;
IN: webapps.source
global [
! Serve up our own source code
"source" [
[
"" resource-path "doc-root" set
[
drop
serving-html
[ swap htmlize-stream ] with-html-stream
] serve-file-hook set
file-responder
] with-scope
] add-simple-responder
] bind

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

@ -1010,7 +1010,8 @@ FUNCTION: HANDLE GetStdHandle ( DWORD nStdHandle ) ;
! FUNCTION: GetSystemDefaultLCID ! FUNCTION: GetSystemDefaultLCID
! FUNCTION: GetSystemDefaultUILanguage ! FUNCTION: GetSystemDefaultUILanguage
! FUNCTION: GetSystemDirectoryA ! FUNCTION: GetSystemDirectoryA
! FUNCTION: GetSystemDirectoryW FUNCTION: UINT GetSystemDirectoryW ( LPTSTR lpBuffer, UINT uSize ) ;
: GetSystemDirectory GetSystemDirectoryW ; inline
FUNCTION: void GetSystemInfo ( LPSYSTEM_INFO lpSystemInfo ) ; FUNCTION: void GetSystemInfo ( LPSYSTEM_INFO lpSystemInfo ) ;
! FUNCTION: GetSystemPowerStatus ! FUNCTION: GetSystemPowerStatus
! FUNCTION: GetSystemRegistryQuota ! FUNCTION: GetSystemRegistryQuota
@ -1019,7 +1020,8 @@ FUNCTION: void GetSystemTime ( LPSYSTEMTIME lpSystemTime ) ;
FUNCTION: void GetSystemTimeAsFileTime ( LPFILETIME lpSystemTimeAsFileTime ) ; FUNCTION: void GetSystemTimeAsFileTime ( LPFILETIME lpSystemTimeAsFileTime ) ;
! FUNCTION: GetSystemTimes ! FUNCTION: GetSystemTimes
! FUNCTION: GetSystemWindowsDirectoryA ! FUNCTION: GetSystemWindowsDirectoryA
! FUNCTION: GetSystemWindowsDirectoryW FUNCTION: UINT GetSystemWindowsDirectoryW ( LPTSTR lpBuffer, UINT uSize ) ;
: GetSystemWindowsDirectory GetSystemWindowsDirectoryW ; inline
! FUNCTION: GetSystemWow64DirectoryA ! FUNCTION: GetSystemWow64DirectoryA
! FUNCTION: GetSystemWow64DirectoryW ! FUNCTION: GetSystemWow64DirectoryW
! FUNCTION: GetTapeParameters ! FUNCTION: GetTapeParameters
@ -1057,7 +1059,8 @@ FUNCTION: BOOL GetVersionExW ( LPOSVERSIONINFO lpVersionInfo ) ;
! FUNCTION: GetVolumePathNamesForVolumeNameW ! FUNCTION: GetVolumePathNamesForVolumeNameW
! FUNCTION: GetVolumePathNameW ! FUNCTION: GetVolumePathNameW
! FUNCTION: GetWindowsDirectoryA ! FUNCTION: GetWindowsDirectoryA
! FUNCTION: GetWindowsDirectoryW FUNCTION: UINT GetWindowsDirectoryW ( LPTSTR lpBuffer, UINT uSize ) ;
: GetWindowsDirectory GetWindowsDirectoryW ; inline
! FUNCTION: GetWriteWatch ! FUNCTION: GetWriteWatch
! FUNCTION: GlobalAddAtomA ! FUNCTION: GlobalAddAtomA
! FUNCTION: GlobalAddAtomW ! FUNCTION: GlobalAddAtomW

1
extra/windows/nt/nt.factor
View File

@ -6,6 +6,7 @@ USING: alien sequences ;
{ "kernel32" "kernel32.dll" "stdcall" } { "kernel32" "kernel32.dll" "stdcall" }
{ "winsock" "ws2_32.dll" "stdcall" } { "winsock" "ws2_32.dll" "stdcall" }
{ "mswsock" "mswsock.dll" "stdcall" } { "mswsock" "mswsock.dll" "stdcall" }
{ "shell32" "shell32.dll" "stdcall" }
{ "libc" "msvcrt.dll" "cdecl" } { "libc" "msvcrt.dll" "cdecl" }
{ "libm" "msvcrt.dll" "cdecl" } { "libm" "msvcrt.dll" "cdecl" }
{ "gl" "opengl32.dll" "stdcall" } { "gl" "opengl32.dll" "stdcall" }

132
extra/windows/shell32/shell32.factor Normal file
View File

@ -0,0 +1,132 @@
USING: alien alien.c-types alien.syntax combinators
kernel windows windows.user32 ;
IN: windows.shell32
: CSIDL_DESKTOP HEX: 00 ; inline
: CSIDL_INTERNET HEX: 01 ; inline
: CSIDL_PROGRAMS HEX: 02 ; inline
: CSIDL_CONTROLS HEX: 03 ; inline
: CSIDL_PRINTERS HEX: 04 ; inline
: CSIDL_PERSONAL HEX: 05 ; inline
: CSIDL_FAVORITES HEX: 06 ; inline
: CSIDL_STARTUP HEX: 07 ; inline
: CSIDL_RECENT HEX: 08 ; inline
: CSIDL_SENDTO HEX: 09 ; inline
: CSIDL_BITBUCKET HEX: 0a ; inline
: CSIDL_STARTMENU HEX: 0b ; inline
: CSIDL_MYDOCUMENTS HEX: 0c ; inline
: CSIDL_MYMUSIC HEX: 0d ; inline
: CSIDL_MYVIDEO HEX: 0e ; inline
: CSIDL_DESKTOPDIRECTORY HEX: 10 ; inline
: CSIDL_DRIVES HEX: 11 ; inline
: CSIDL_NETWORK HEX: 12 ; inline
: CSIDL_NETHOOD HEX: 13 ; inline
: CSIDL_FONTS HEX: 14 ; inline
: CSIDL_TEMPLATES HEX: 15 ; inline
: CSIDL_COMMON_STARTMENU HEX: 16 ; inline
: CSIDL_COMMON_PROGRAMS HEX: 17 ; inline
: CSIDL_COMMON_STARTUP HEX: 18 ; inline
: CSIDL_COMMON_DESKTOPDIRECTORY HEX: 19 ; inline
: CSIDL_APPDATA HEX: 1a ; inline
: CSIDL_PRINTHOOD HEX: 1b ; inline
: CSIDL_LOCAL_APPDATA HEX: 1c ; inline
: CSIDL_ALTSTARTUP HEX: 1d ; inline
: CSIDL_COMMON_ALTSTARTUP HEX: 1e ; inline
: CSIDL_COMMON_FAVORITES HEX: 1f ; inline
: CSIDL_INTERNET_CACHE HEX: 20 ; inline
: CSIDL_COOKIES HEX: 21 ; inline
: CSIDL_HISTORY HEX: 22 ; inline
: CSIDL_COMMON_APPDATA HEX: 23 ; inline
: CSIDL_WINDOWS HEX: 24 ; inline
: CSIDL_SYSTEM HEX: 25 ; inline
: CSIDL_PROGRAM_FILES HEX: 26 ; inline
: CSIDL_MYPICTURES HEX: 27 ; inline
: CSIDL_PROFILE HEX: 28 ; inline
: CSIDL_SYSTEMX86 HEX: 29 ; inline
: CSIDL_PROGRAM_FILESX86 HEX: 2a ; inline
: CSIDL_PROGRAM_FILES_COMMON HEX: 2b ; inline
: CSIDL_PROGRAM_FILES_COMMONX86 HEX: 2c ; inline
: CSIDL_COMMON_TEMPLATES HEX: 2d ; inline
: CSIDL_COMMON_DOCUMENTS HEX: 2e ; inline
: CSIDL_COMMON_ADMINTOOLS HEX: 2f ; inline
: CSIDL_ADMINTOOLS HEX: 30 ; inline
: CSIDL_CONNECTIONS HEX: 31 ; inline
: CSIDL_COMMON_MUSIC HEX: 35 ; inline
: CSIDL_COMMON_PICTURES HEX: 36 ; inline
: CSIDL_COMMON_VIDEO HEX: 37 ; inline
: CSIDL_RESOURCES HEX: 38 ; inline
: CSIDL_RESOURCES_LOCALIZED HEX: 39 ; inline
: CSIDL_COMMON_OEM_LINKS HEX: 3a ; inline
: CSIDL_CDBURN_AREA HEX: 3b ; inline
: CSIDL_COMPUTERSNEARME HEX: 3d ; inline
: CSIDL_PROFILES HEX: 3e ; inline
: CSIDL_FOLDER_MASK HEX: ff ; inline
: CSIDL_FLAG_PER_USER_INIT HEX: 800 ; inline
: CSIDL_FLAG_NO_ALIAS HEX: 1000 ; inline
: CSIDL_FLAG_DONT_VERIFY HEX: 4000 ; inline
: CSIDL_FLAG_CREATE HEX: 8000 ; inline
: CSIDL_FLAG_MASK HEX: ff00 ; inline
: S_OK 0 ; inline
: S_FALSE 1 ; inline
: E_FAIL HEX: 80004005 ; inline
: E_INVALIDARG HEX: 80070057 ; inline
: ERROR_FILE_NOT_FOUND 2 ; inline
: SHGFP_TYPE_CURRENT 0 ; inline
: SHGFP_TYPE_DEFAULT 1 ; inline
LIBRARY: shell32
FUNCTION: HRESULT SHGetFolderPathW ( HWND hwndOwner, int nFolder, HANDLE hToken, DWORD dwReserved, LPTSTR pszPath ) ;
: SHGetFolderPath SHGetFolderPathW ; inline
FUNCTION: HINSTANCE ShellExecuteW ( HWND hwnd, LPCTSTR lpOperation, LPCTSTR lpFile, LPCTSTR lpParameters, LPCTSTR lpDirectory, INT nShowCmd ) ;
: ShellExecute ShellExecuteW ; inline
: open-in-explorer ( dir -- )
f "open" rot f f SW_SHOWNORMAL ShellExecute drop ;
: shell32-error ( n -- )
dup S_OK = [
drop
] [
{
! { ERROR_FILE_NOT_FOUND [ "file not found" throw ] }
! { E_INVALIDARG [ "invalid arg" throw ] }
[ (win32-error-string) throw ]
} case
] if ;
: shell32-directory ( n -- str )
f swap f SHGFP_TYPE_DEFAULT
MAX_UNICODE_PATH "ushort" <c-array>
[ SHGetFolderPath shell32-error ] keep alien>u16-string ;
: desktop ( -- str )
CSIDL_DESKTOPDIRECTORY shell32-directory ;
: my-documents ( -- str )
CSIDL_PERSONAL shell32-directory ;
: application-data ( -- str )
CSIDL_APPDATA shell32-directory ;
: windows ( -- str )
CSIDL_WINDOWS shell32-directory ;
: programs ( -- str )
CSIDL_PROGRAMS shell32-directory ;
: program-files ( -- str )
CSIDL_PROGRAM_FILES shell32-directory ;
: program-files-x86 ( -- str )
CSIDL_PROGRAM_FILESX86 shell32-directory ;
: program-files-common ( -- str )
CSIDL_PROGRAM_FILES_COMMON shell32-directory ;
: program-files-common-x86 ( -- str )
CSIDL_PROGRAM_FILES_COMMONX86 shell32-directory ;

1
extra/windows/windows.factor
View File

@ -7,6 +7,7 @@ IN: windows
: lo-word ( wparam -- lo ) <short> *short ; inline : lo-word ( wparam -- lo ) <short> *short ; inline
: hi-word ( wparam -- hi ) -16 shift lo-word ; inline : hi-word ( wparam -- hi ) -16 shift lo-word ; inline
: MAX_UNICODE_PATH 32768 ; inline
! You must LocalFree the return value! ! You must LocalFree the return value!
FUNCTION: void* error_message ( DWORD id ) ; FUNCTION: void* error_message ( DWORD id ) ;

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

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

12
extra/xmode/README.txt
View File

@ -32,10 +32,10 @@ to depend on:
it inherits the value of the NO_WORD_SEP attribute from the previous it inherits the value of the NO_WORD_SEP attribute from the previous
RULES tag. RULES tag.
The Factor implementation does not duplicate this behavior. The Factor implementation does not duplicate this behavior. If you
find a mode file which depends on this flaw, please fix it and submit
the changes to the jEdit project.
This is still a work in progress. If you find any behavioral differences If you wish to contribute a new or improved mode file, please contact
between the Factor implementation and the original jEdit code, please the jEdit project. Updated mode files in jEdit will be periodically
report them as bugs. Also, if you wish to contribute a new or improved imported into the Factor source tree.
mode file, please contact the jEdit project. Updated mode files in jEdit
will be periodically imported into the Factor source tree.

4
extra/xmode/catalog/catalog-tests.factor
View File

@ -5,5 +5,7 @@ kernel sequences io ;
[ t ] [ modes hashtable? ] unit-test [ t ] [ modes hashtable? ] unit-test
[ ] [ [ ] [
modes keys [ dup print load-mode drop reset-modes ] each modes keys [
dup print flush load-mode drop reset-modes
] each
] unit-test ] unit-test

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

@ -26,7 +26,7 @@ TAGS>
"extra/xmode/modes/catalog" resource-path "extra/xmode/modes/catalog" resource-path
<file-reader> read-xml parse-modes-tag ; <file-reader> read-xml parse-modes-tag ;
: modes ( -- ) : modes ( -- assoc )
\ modes get-global [ \ modes get-global [
load-catalog dup \ modes set-global load-catalog dup \ modes set-global
] unless* ; ] unless* ;

30
extra/xmode/code2html/code2html.factor Normal file → Executable file
View File

@ -15,8 +15,8 @@ IN: xmode.code2html
: htmlize-line ( line-context line rules -- line-context' ) : htmlize-line ( line-context line rules -- line-context' )
tokenize-line htmlize-tokens ; tokenize-line htmlize-tokens ;
: htmlize-lines ( lines rules -- ) : htmlize-lines ( lines mode -- )
<pre> f -rot [ htmlize-line nl ] curry each drop </pre> ; f swap load-mode [ htmlize-line nl ] curry reduce drop ;
: default-stylesheet ( -- ) : default-stylesheet ( -- )
<style> <style>
@ -24,22 +24,22 @@ IN: xmode.code2html
resource-path <file-reader> contents write resource-path <file-reader> contents write
</style> ; </style> ;
: htmlize-file ( path -- ) : htmlize-stream ( path stream -- )
dup <file-reader> lines dup empty? [ 2drop ] [ lines swap
swap dup ".html" append <file-writer> [
[
<html> <html>
<head> <head>
<title> dup write </title>
default-stylesheet default-stylesheet
<title> dup write </title>
</head> </head>
<body> <body>
over first <pre>
find-mode over empty?
load-mode [ 2drop ]
htmlize-lines [ over first find-mode htmlize-lines ] if
</pre>
</body> </body>
</html> </html> ;
] with-html-stream
] with-stream : htmlize-file ( path -- )
] if ; dup <file-reader> over ".html" append <file-writer>
[ htmlize-stream ] with-stream ;

2
extra/xmode/keyword-map/keyword-map.factor
View File

@ -22,8 +22,6 @@ M: keyword-map set-at
M: keyword-map clear-assoc M: keyword-map clear-assoc
[ delegate clear-assoc ] keep invalid-no-word-sep ; [ delegate clear-assoc ] keep invalid-no-word-sep ;
M: keyword-map assoc-find >r delegate r> assoc-find ;
M: keyword-map >alist delegate >alist ; M: keyword-map >alist delegate >alist ;
: (keyword-map-no-word-sep) : (keyword-map-no-word-sep)

35
extra/xmode/loader/loader.factor
View File

@ -1,11 +1,12 @@
USING: xmode.tokens xmode.rules USING: xmode.tokens xmode.rules xmode.keyword-map xml.data
xmode.keyword-map xml.data xml.utilities xml assocs xml.utilities xml assocs kernel combinators sequences
kernel combinators sequences math.parser namespaces parser math.parser namespaces parser xmode.utilities regexp io.files ;
xmode.utilities regexp io.files ;
IN: xmode.loader IN: xmode.loader
! Based on org.gjt.sp.jedit.XModeHandler ! Based on org.gjt.sp.jedit.XModeHandler
SYMBOL: ignore-case?
! Attribute utilities ! Attribute utilities
: string>boolean ( string -- ? ) "TRUE" = ; : string>boolean ( string -- ? ) "TRUE" = ;
@ -32,10 +33,13 @@ IN: xmode.loader
swap [ at string>boolean ] curry map first3 ; swap [ at string>boolean ] curry map first3 ;
: parse-literal-matcher ( tag -- matcher ) : parse-literal-matcher ( tag -- matcher )
dup children>string swap position-attrs <matcher> ; dup children>string
ignore-case? get <string-matcher>
swap position-attrs <matcher> ;
: parse-regexp-matcher ( tag -- matcher ) : parse-regexp-matcher ( tag -- matcher )
dup children>string <regexp> swap position-attrs <matcher> ; dup children>string ignore-case? get <regexp>
swap position-attrs <matcher> ;
! SPAN's children ! SPAN's children
<TAGS: parse-begin/end-tag <TAGS: parse-begin/end-tag
@ -130,22 +134,25 @@ RULE: MARK_FOLLOWING mark-following-rule
RULE: MARK_PREVIOUS mark-previous-rule RULE: MARK_PREVIOUS mark-previous-rule
shared-tag-attrs match-type-attr literal-start ; shared-tag-attrs match-type-attr literal-start ;
: parse-keyword-tag : parse-keyword-tag ( tag keyword-map -- )
dup name-tag string>token swap children>string rot set-at ; >r dup name-tag string>token swap children>string r> set-at ;
TAG: KEYWORDS ( rule-set tag -- key value ) TAG: KEYWORDS ( rule-set tag -- key value )
>r rule-set-keywords r> ignore-case? get <keyword-map>
child-tags [ parse-keyword-tag ] curry* each ; swap child-tags [ over parse-keyword-tag ] each
swap set-rule-set-keywords ;
TAGS> TAGS>
: ?<regexp> dup [ ignore-case? get <regexp> ] when ;
: (parse-rules-tag) ( tag -- rule-set ) : (parse-rules-tag) ( tag -- rule-set )
<rule-set> <rule-set>
{ {
{ "SET" string>rule-set-name set-rule-set-name } { "SET" string>rule-set-name set-rule-set-name }
{ "IGNORE_CASE" string>boolean set-rule-set-ignore-case? } { "IGNORE_CASE" string>boolean set-rule-set-ignore-case? }
{ "HIGHLIGHT_DIGITS" string>boolean set-rule-set-highlight-digits? } { "HIGHLIGHT_DIGITS" string>boolean set-rule-set-highlight-digits? }
{ "DIGIT_RE" <regexp> set-rule-set-digit-re } ! XXX { "DIGIT_RE" ?<regexp> set-rule-set-digit-re }
{ "ESCAPE" f add-escape-rule } { "ESCAPE" f add-escape-rule }
{ "DEFAULT" string>token set-rule-set-default } { "DEFAULT" string>token set-rule-set-default }
{ "NO_WORD_SEP" f set-rule-set-no-word-sep } { "NO_WORD_SEP" f set-rule-set-no-word-sep }
@ -153,9 +160,9 @@ TAGS>
: parse-rules-tag ( tag -- rule-set ) : parse-rules-tag ( tag -- rule-set )
dup (parse-rules-tag) [ dup (parse-rules-tag) [
swap child-tags [ dup rule-set-ignore-case? ignore-case? [
parse-rule-tag swap child-tags [ parse-rule-tag ] curry* each
] curry* each ] with-variable
] keep ; ] keep ;
: merge-rule-set-props ( props rule-set -- ) : merge-rule-set-props ( props rule-set -- )

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

@ -109,3 +109,21 @@ IN: temporary
] [ ] [
f "$FOO" "shellscript" load-mode tokenize-line nip f "$FOO" "shellscript" load-mode tokenize-line nip
] unit-test ] unit-test
[
{
T{ token f "AND" KEYWORD1 }
}
] [
f "AND" "pascal" load-mode tokenize-line nip
] unit-test
[
{
T{ token f "Comment {" COMMENT1 }
T{ token f "XXX" COMMENT1 }
T{ token f "}" COMMENT1 }
}
] [
f "Comment {XXX}" "rebol" load-mode tokenize-line nip
] unit-test

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

@ -1,8 +1,8 @@
IN: xmode.marker IN: xmode.marker
USING: kernel namespaces xmode.rules xmode.tokens USING: kernel namespaces xmode.rules xmode.tokens
xmode.marker.state xmode.marker.context xmode.marker.state xmode.marker.context xmode.utilities
xmode.utilities xmode.catalog sequences math xmode.catalog sequences math assocs combinators combinators.lib
assocs combinators combinators.lib strings regexp splitting ; strings regexp splitting parser-combinators ;
! Based on org.gjt.sp.jedit.syntax.TokenMarker ! Based on org.gjt.sp.jedit.syntax.TokenMarker
@ -15,8 +15,8 @@ assocs combinators combinators.lib strings regexp splitting ;
[ dup [ digit? ] contains? ] [ dup [ digit? ] contains? ]
[ [
dup [ digit? ] all? [ dup [ digit? ] all? [
current-rule-set rule-set-digit-re dup current-rule-set rule-set-digit-re
[ dupd 2drop f ] [ drop f ] if dup [ dupd matches? ] [ drop f ] if
] unless* ] unless*
] ]
} && nip ; } && nip ;
@ -26,7 +26,7 @@ assocs combinators combinators.lib strings regexp splitting ;
: resolve-delegate ( name -- rules ) : resolve-delegate ( name -- rules )
dup string? [ dup string? [
"::" split1 [ swap load-mode at ] [ rule-sets get at ] if* "::" split1 [ swap load-mode ] [ rule-sets get ] if* at
] when ; ] when ;
: rule-set-keyword-maps ( ruleset -- seq ) : rule-set-keyword-maps ( ruleset -- seq )
@ -45,13 +45,6 @@ assocs combinators combinators.lib strings regexp splitting ;
dup mark-number [ ] [ mark-keyword ] ?if dup mark-number [ ] [ mark-keyword ] ?if
[ prev-token, ] when* ; [ prev-token, ] when* ;
: check-terminate-char ( -- )
current-rule-set rule-set-terminate-char [
position get <= [
terminated? on
] when
] when* ;
: current-char ( -- char ) : current-char ( -- char )
position get line get nth ; position get line get nth ;
@ -69,20 +62,27 @@ M: rule match-position drop position get ;
[ over matcher-at-word-start? over last-offset get = implies ] [ over matcher-at-word-start? over last-offset get = implies ]
} && 2nip ; } && 2nip ;
GENERIC: text-matches? ( position text -- match-count/f ) : rest-of-line ( -- str )
line get position get tail-slice ;
M: f text-matches? 2drop f ; GENERIC: text-matches? ( string text -- match-count/f )
M: string text-matches? M: f text-matches?
! XXX ignore case 2drop f ;
>r line get swap tail-slice r>
[ head? ] keep length and ;
! M: regexp text-matches? ... ; M: string-matcher text-matches?
[
dup string-matcher-string
swap string-matcher-ignore-case?
string-head?
] keep string-matcher-string length and ;
M: regexp text-matches?
>r >string r> match-head ;
: rule-start-matches? ( rule -- match-count/f ) : rule-start-matches? ( rule -- match-count/f )
dup rule-start tuck swap can-match-here? [ dup rule-start tuck swap can-match-here? [
position get swap matcher-text text-matches? rest-of-line swap matcher-text text-matches?
] [ ] [
drop f drop f
] if ; ] if ;
@ -92,8 +92,8 @@ M: string text-matches?
dup rule-start swap can-match-here? 0 and dup rule-start swap can-match-here? 0 and
] [ ] [
dup rule-end tuck swap can-match-here? [ dup rule-end tuck swap can-match-here? [
position get swap matcher-text rest-of-line
context get line-context-end or swap matcher-text context get line-context-end or
text-matches? text-matches?
] [ ] [
drop f drop f
@ -284,8 +284,6 @@ M: mark-previous-rule handle-rule-start
: mark-token-loop ( -- ) : mark-token-loop ( -- )
position get line get length < [ position get line get length < [
check-terminate-char
{ {
[ check-end-delegate ] [ check-end-delegate ]
[ check-every-rule ] [ check-every-rule ]
@ -302,8 +300,7 @@ 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 rule-no-line-break? [
terminated? get or [
pop-context pop-context
unwind-no-line-break unwind-no-line-break
] when ] when

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

@ -16,7 +16,6 @@ SYMBOL: seen-whitespace-end?
SYMBOL: escaped? SYMBOL: escaped?
SYMBOL: process-escape? SYMBOL: process-escape?
SYMBOL: delegate-end-escaped? SYMBOL: delegate-end-escaped?
SYMBOL: terminated?
: current-rule ( -- rule ) : current-rule ( -- rule )
context get line-context-in-rule ; context get line-context-in-rule ;
@ -52,10 +51,6 @@ SYMBOL: terminated?
dup context set dup context set
f swap set-line-context-in-rule ; f swap set-line-context-in-rule ;
: terminal-rule-set ( -- rule-set )
get-rule-set rule-set-default standard-rule-set
push-context ;
: init-token-marker ( prev-context line rules -- ) : init-token-marker ( prev-context line rules -- )
rule-sets set rule-sets set
line set line set

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

@ -1,7 +1,11 @@
USING: xmode.tokens xmode.keyword-map kernel USING: xmode.tokens xmode.keyword-map kernel
sequences vectors assocs strings memoize ; sequences vectors assocs strings memoize regexp ;
IN: xmode.rules IN: xmode.rules
TUPLE: string-matcher string ignore-case? ;
C: <string-matcher> string-matcher
! Based on org.gjt.sp.jedit.syntax.ParserRuleSet ! Based on org.gjt.sp.jedit.syntax.ParserRuleSet
TUPLE: rule-set TUPLE: rule-set
name name
@ -20,12 +24,11 @@ no-word-sep
: init-rule-set ( ruleset -- ) : init-rule-set ( ruleset -- )
#! Call after constructor. #! Call after constructor.
>r H{ } clone H{ } clone V{ } clone f <keyword-map> r> >r H{ } clone H{ } clone V{ } clone r>
{ {
set-rule-set-rules set-rule-set-rules
set-rule-set-props set-rule-set-props
set-rule-set-imports set-rule-set-imports
set-rule-set-keywords
} set-slots ; } set-slots ;
: <rule-set> ( -- ruleset ) : <rule-set> ( -- ruleset )
@ -46,8 +49,9 @@ MEMO: standard-rule-set ( id -- ruleset )
] when* ; ] when* ;
: rule-set-no-word-sep* ( ruleset -- str ) : rule-set-no-word-sep* ( ruleset -- str )
dup rule-set-keywords keyword-map-no-word-sep* dup rule-set-no-word-sep
swap rule-set-no-word-sep "_" 3append ; swap rule-set-keywords dup [ keyword-map-no-word-sep* ] when
"_" 3append ;
! Match restrictions ! Match restrictions
TUPLE: matcher text at-line-start? at-whitespace-end? at-word-start? ; TUPLE: matcher text at-line-start? at-whitespace-end? at-word-start? ;
@ -93,20 +97,32 @@ TUPLE: mark-previous-rule ;
TUPLE: escape-rule ; TUPLE: escape-rule ;
: <escape-rule> ( string -- rule ) : <escape-rule> ( string -- rule )
f f f <matcher> f <string-matcher> f f f <matcher>
escape-rule construct-rule escape-rule construct-rule
[ set-rule-start ] keep ; [ set-rule-start ] keep ;
GENERIC: text-hash-char ( text -- ch )
M: f text-hash-char ;
M: string-matcher text-hash-char string-matcher-string first ;
M: regexp text-hash-char drop f ;
: rule-chars* ( rule -- string ) : rule-chars* ( rule -- string )
dup rule-chars dup rule-chars
swap rule-start matcher-text swap rule-start matcher-text
dup string? [ first add ] [ drop ] if ; text-hash-char [ add ] when* ;
: add-rule ( rule ruleset -- ) : add-rule ( rule ruleset -- )
>r dup rule-chars* >upper swap >r dup rule-chars* >upper swap
r> rule-set-rules inverted-index ; r> rule-set-rules inverted-index ;
: add-escape-rule ( string ruleset -- ) : add-escape-rule ( string ruleset -- )
over [
>r <escape-rule> r> >r <escape-rule> r>
2dup set-rule-set-escape-rule 2dup set-rule-set-escape-rule
add-rule ; add-rule
] [
2drop
] if ;

2
misc/factor.sh
View File

@ -57,7 +57,7 @@ check_installed_programs() {
check_library_exists() { check_library_exists() {
GCC_TEST=factor-library-test.c GCC_TEST=factor-library-test.c
GCC_OUT=factor-library-test.out GCC_OUT=factor-library-test.out
echo -n "Checking for library $1" echo -n "Checking for library $1..."
echo "int main(){return 0;}" > $GCC_TEST echo "int main(){return 0;}" > $GCC_TEST
gcc $GCC_TEST -o $GCC_OUT -l $1 gcc $GCC_TEST -o $GCC_OUT -l $1
if [[ $? -ne 0 ]] ; then if [[ $? -ne 0 ]] ; then

0
extra/furnace/scaffold/crud-templates/edit.furnace → unmaintained/scaffold/crud-templates/edit.furnace
View File

0
extra/furnace/scaffold/crud-templates/list.furnace → unmaintained/scaffold/crud-templates/list.furnace
View File

0
extra/furnace/scaffold/crud-templates/show.furnace → unmaintained/scaffold/crud-templates/show.furnace
View File

7
extra/furnace/scaffold/scaffold.factor → unmaintained/scaffold/scaffold.factor
View File

@ -2,7 +2,7 @@ USING: http.server help.markup help.syntax kernel prettyprint
sequences parser namespaces words classes math tuples.private sequences parser namespaces words classes math tuples.private
quotations arrays strings ; quotations arrays strings ;
IN: furnace IN: furnace.scaffold
TUPLE: furnace-model model ; TUPLE: furnace-model model ;
C: <furnace-model> furnace-model C: <furnace-model> furnace-model
@ -40,6 +40,11 @@ HELP: crud-lookup*
{ $values { "string" string } { "class" class } { "tuple" tuple } } { $values { "string" string } { "class" class } { "tuple" tuple } }
"A CRUD utility function - same as crud-lookup, but always returns a tuple of the given class. When the lookup fails, returns a tuple of the given class with all slots set to f." ; "A CRUD utility function - same as crud-lookup, but always returns a tuple of the given class. When the lookup fails, returns a tuple of the given class with all slots set to f." ;
: render-page ( model template title -- )
[
[ render-component ] simple-html-document
] serve-html ;
: crud-page ( model template title -- ) : crud-page ( model template title -- )
[ "libs/furnace/crud-templates" template-path set render-page ] [ "libs/furnace/crud-templates" template-path set render-page ]
with-scope ; with-scope ;

8
vm/os-linux-x86-64.h
View File

@ -1,2 +1,10 @@
#include <ucontext.h>
INLINE void *ucontext_stack_pointer(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
return (void *)ucontext->uc_mcontext.gregs[15];
}
#define UAP_PROGRAM_COUNTER(ucontext) \ #define UAP_PROGRAM_COUNTER(ucontext) \
(((ucontext_t *)(ucontext))->uc_mcontext.gregs[16]) (((ucontext_t *)(ucontext))->uc_mcontext.gregs[16])

4
vm/os-windows-nt.c
View File

@ -10,9 +10,9 @@ s64 current_millis(void)
DEFINE_PRIMITIVE(cwd) DEFINE_PRIMITIVE(cwd)
{ {
F_CHAR buf[MAX_PATH + 4]; F_CHAR buf[MAX_UNICODE_PATH];
if(!GetCurrentDirectory(MAX_PATH + 4, buf)) if(!GetCurrentDirectory(MAX_UNICODE_PATH, buf))
io_error(); io_error();
box_u16_string(buf); box_u16_string(buf);

1
vm/platform.h
View File

@ -70,7 +70,6 @@
#elif defined(FACTOR_ARM) #elif defined(FACTOR_ARM)
#include "os-linux-arm.h" #include "os-linux-arm.h"
#elif defined(FACTOR_AMD64) #elif defined(FACTOR_AMD64)
#include "os-unix-ucontext.h"
#include "os-linux-x86-64.h" #include "os-linux-x86-64.h"
#else #else
#error "Unsupported Linux flavor" #error "Unsupported Linux flavor"