Merge git://factorcode.org/git/factor
Conflicts: extra/random-tester/random/random.factor extra/random-tester/utils/utils.factorrelease
commit
717ea6206a
|
@ -79,6 +79,10 @@ M: sequence hashcode*
|
|||
dup empty? [
|
||||
drop
|
||||
] [
|
||||
hash-case-table hash-dispatch-quot
|
||||
[ dup hashcode >fixnum ] swap append
|
||||
dup length 4 <= [
|
||||
case>quot
|
||||
] [
|
||||
hash-case-table hash-dispatch-quot
|
||||
[ dup hashcode >fixnum ] swap append
|
||||
] if
|
||||
] if ;
|
||||
|
|
|
@ -16,9 +16,10 @@ M: object inference-error-major? drop t ;
|
|||
|
||||
: begin-batch ( seq -- )
|
||||
batch-mode on
|
||||
[
|
||||
"Compiling " % length # " words..." %
|
||||
] "" make print flush
|
||||
"quiet" get [ drop ] [
|
||||
[ "Compiling " % length # " words..." % ] "" make
|
||||
print flush
|
||||
] if
|
||||
V{ } clone compile-errors set-global ;
|
||||
|
||||
: compile-error. ( pair -- )
|
||||
|
|
|
@ -50,7 +50,7 @@ IN: temporary
|
|||
global keys =
|
||||
] 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
|
||||
|
||||
|
|
|
@ -56,3 +56,8 @@ IN: temporary
|
|||
\ recursive compile
|
||||
|
||||
[ ] [ t recursive ] unit-test
|
||||
|
||||
! Make sure error reporting works
|
||||
|
||||
[ [ dup ] compile-1 ] unit-test-fails
|
||||
[ [ drop ] compile-1 ] unit-test-fails
|
||||
|
|
|
@ -126,3 +126,17 @@ TUPLE: pathname string ;
|
|||
C: <pathname> pathname
|
||||
|
||||
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 ;
|
||||
|
|
|
@ -8,7 +8,7 @@ assocs quotations sequences.private io.binary io.crc32
|
|||
io.streams.string layouts splitting math.intervals
|
||||
math.floats.private tuples tuples.private classes
|
||||
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
|
||||
! its second-to-last input
|
||||
|
@ -50,6 +50,20 @@ float-arrays combinators.private ;
|
|||
{ [ dup disjoint-eq? ] [ [ f ] inline-literals ] }
|
||||
} 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,
|
||||
! the first input is equal to the second
|
||||
\ eq? [
|
||||
|
|
|
@ -111,7 +111,7 @@ optimizer.def-use generic.standard ;
|
|||
|
||||
: post-process ( class interval node -- classes intervals )
|
||||
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 ;
|
||||
|
||||
: math-output-interval-1 ( node word -- interval )
|
||||
|
|
|
@ -26,6 +26,8 @@ HINTS: do-trans-map string ;
|
|||
over push
|
||||
] if ;
|
||||
|
||||
HINTS: do-line vector string ;
|
||||
|
||||
: (reverse-complement) ( seq -- )
|
||||
readln [ do-line (reverse-complement) ] [ show-seq ] if* ;
|
||||
|
||||
|
|
|
@ -2,8 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: arrays hashtables io io.streams.string kernel math
|
||||
math.vectors math.functions math.parser
|
||||
namespaces sequences strings tuples system ;
|
||||
math.vectors math.functions math.parser namespaces sequences
|
||||
strings tuples system debugger ;
|
||||
IN: calendar
|
||||
|
||||
TUPLE: timestamp year month day hour minute second gmt-offset ;
|
||||
|
@ -316,7 +316,28 @@ M: timestamp <=> ( ts1 ts2 -- n )
|
|||
: timestamp>rfc3339 ( timestamp -- str )
|
||||
>gmt [
|
||||
(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 )
|
||||
[
|
||||
|
|
|
@ -65,8 +65,8 @@ PROTOCOL: prettyprint-section-protocol
|
|||
|
||||
: define-mimic ( group mimicker mimicked -- )
|
||||
>r >r group-words r> r> [
|
||||
pick "methods" word-prop at
|
||||
[ method-def <method> spin define-method ] [ 3drop ] if*
|
||||
pick "methods" word-prop at dup
|
||||
[ method-def <method> spin define-method ] [ 3drop ] if
|
||||
] 2curry each ;
|
||||
|
||||
: MIMIC:
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
|
@ -0,0 +1 @@
|
|||
Wordpad editor integration
|
|
@ -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
|
|
@ -5,7 +5,7 @@ USING: kernel vectors io assocs quotations splitting strings
|
|||
continuations tuples classes io.files
|
||||
http http.server.templating http.basic-authentication
|
||||
webapps.callback html html.elements
|
||||
http.server.responders furnace.validator ;
|
||||
http.server.responders furnace.validator vocabs ;
|
||||
IN: furnace
|
||||
|
||||
SYMBOL: default-action
|
||||
|
@ -101,36 +101,14 @@ SYMBOL: request-params
|
|||
|
||||
: service-post ( url -- ) "response" get swap service-request ;
|
||||
|
||||
: explode-tuple ( tuple -- )
|
||||
dup tuple-slots swap class "slot-names" word-prop
|
||||
[ set ] 2each ;
|
||||
: send-resource ( name -- )
|
||||
template-path get swap path+ resource-path <file-reader>
|
||||
stdio get stream-copy ;
|
||||
|
||||
SYMBOL: model
|
||||
|
||||
: call-template ( model template -- )
|
||||
[
|
||||
>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 ;
|
||||
: render-template ( template -- )
|
||||
template-path get swap path+
|
||||
".furnace" append resource-path
|
||||
run-template-file ;
|
||||
|
||||
: web-app ( name default path -- )
|
||||
[
|
||||
|
@ -141,3 +119,22 @@ SYMBOL: model
|
|||
[ service-post ] "post" set
|
||||
! [ service-head ] "head" set
|
||||
] 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> ;
|
||||
|
|
|
@ -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
|
||||
|
||||
TUPLE: wince ;
|
||||
T{ wince } os set-global
|
||||
|
||||
: memory-status ( -- MEMORYSTATUS )
|
||||
|
|
|
@ -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 ;
|
||||
IN: hardware-info.windows.nt
|
||||
|
||||
TUPLE: winnt ;
|
||||
T{ winnt } os set-global
|
||||
|
||||
: memory-status ( -- MEMORYSTATUSEX )
|
||||
|
|
|
@ -1,5 +1,6 @@
|
|||
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
|
||||
|
||||
TUPLE: wince ;
|
||||
|
@ -53,6 +54,22 @@ M: windows cpus ( -- n )
|
|||
: sse3? ( -- ? )
|
||||
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: winnt? hardware-info.windows.nt
|
||||
|
||||
|
|
|
@ -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 " { $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." }
|
||||
{ "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" }
|
||||
{ $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.files" } " - several new file system manipulation words added" }
|
||||
{ { $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" }
|
||||
{ $list
|
||||
|
@ -264,7 +265,7 @@ ARTICLE: "changes" "Changes in the latest release"
|
|||
{ "Windows can be closed on request now using " { $link close-window } }
|
||||
{ "New icons (Elie Chaftari)" }
|
||||
}
|
||||
{ $subheading "Other" }
|
||||
{ $subheading "Libraries" }
|
||||
{ $list
|
||||
{ "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." }
|
||||
|
@ -273,11 +274,19 @@ ARTICLE: "changes" "Changes in the latest release"
|
|||
{ { $vocab-link "channels" } " - concurrent message passing over message channels" }
|
||||
{ { $vocab-link "destructors" } " - deterministic scope-based resource deallocation (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.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 "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 "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" }
|
||||
{ $subheading "Core" }
|
||||
|
|
|
@ -20,7 +20,7 @@ IN: http
|
|||
dup letter?
|
||||
over LETTER? or
|
||||
over digit? or
|
||||
swap "/_?." member? or ; foldable
|
||||
swap "/_-?." member? or ; foldable
|
||||
|
||||
: url-encode ( str -- str )
|
||||
[
|
||||
|
|
|
@ -38,3 +38,21 @@ M: unix-io make-directory ( path -- )
|
|||
|
||||
M: unix-io delete-directory ( path -- )
|
||||
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"
|
||||
} ;
|
||||
|
|
|
@ -7,7 +7,8 @@ IN: windows.ce.files
|
|||
! M: windows-ce-io normalize-pathname ( string -- string )
|
||||
! 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 ;
|
||||
|
||||
: finish-read ( port status bytes-ret -- )
|
||||
|
|
|
@ -87,9 +87,9 @@ TUPLE: CreateProcess-args
|
|||
pass-environment? [
|
||||
[
|
||||
get-environment
|
||||
[ swap % "=" % % "\0" % ] assoc-each
|
||||
[ "=" swap 3append string>u16-alien % ] assoc-each
|
||||
"\0" %
|
||||
] "" make >c-ushort-array
|
||||
] { } make >c-ushort-array
|
||||
over set-CreateProcess-args-lpEnvironment
|
||||
] when ;
|
||||
|
||||
|
|
|
@ -62,7 +62,7 @@ M: windows-ce-io with-privileges
|
|||
|
||||
: mmap-open ( path access-mode create-mode flProtect access -- handle handle address )
|
||||
{ "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
|
||||
dup close-later
|
||||
dup
|
||||
|
|
|
@ -3,8 +3,8 @@ io.windows.nt io.windows.nt.backend kernel libc math
|
|||
threads windows windows.kernel32 ;
|
||||
IN: io.windows.nt.files
|
||||
|
||||
M: windows-nt-io CreateFile-flags ( -- DWORD )
|
||||
FILE_FLAG_OVERLAPPED ;
|
||||
M: windows-nt-io CreateFile-flags ( DWORD -- DWORD )
|
||||
FILE_FLAG_OVERLAPPED bitor ;
|
||||
|
||||
M: windows-nt-io FileArgs-overlapped ( port -- overlapped )
|
||||
make-overlapped ;
|
||||
|
|
|
@ -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.sockets.impl windows.errors strings io.streams.duplex kernel
|
||||
math namespaces sequences windows windows.kernel32
|
||||
windows.winsock splitting ;
|
||||
windows.shell32 windows.winsock splitting ;
|
||||
IN: io.windows
|
||||
|
||||
TUPLE: windows-nt-io ;
|
||||
TUPLE: 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-socket closesocket drop ;
|
||||
|
@ -23,7 +33,7 @@ TUPLE: win32-file handle ptr overlapped ;
|
|||
: <win32-duplex-stream> ( in out -- 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: add-completion io-backend ( port -- )
|
||||
|
||||
|
@ -31,7 +41,8 @@ M: windows-io normalize-directory ( string -- string )
|
|||
"\\" ?tail drop "\\*" append ;
|
||||
|
||||
: 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 -- )
|
||||
drop ;
|
||||
|
@ -40,24 +51,25 @@ M: win32-file close-handle ( handle -- )
|
|||
win32-file-handle CloseHandle drop ;
|
||||
|
||||
! 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 add-completion
|
||||
] with-destructors ;
|
||||
|
||||
: 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 )
|
||||
normalize-pathname GENERIC_READ OPEN_EXISTING open-file 0 ;
|
||||
GENERIC_READ OPEN_EXISTING 0 open-file 0 ;
|
||||
|
||||
: 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 )
|
||||
normalize-pathname GENERIC_WRITE OPEN_ALWAYS open-file ;
|
||||
GENERIC_WRITE OPEN_ALWAYS 0 open-file ;
|
||||
|
||||
: set-file-pointer ( handle length -- )
|
||||
dupd d>w/w <uint> FILE_BEGIN SetFilePointer
|
||||
|
|
|
@ -32,7 +32,7 @@ M: nehe4-gadget draw-gadget* ( gadget -- )
|
|||
glLoadIdentity
|
||||
-1.5 0.0 -6.0 glTranslatef
|
||||
dup nehe4-gadget-rtri 0.0 1.0 0.0 glRotatef
|
||||
|
||||
|
||||
GL_TRIANGLES [
|
||||
1.0 0.0 0.0 glColor3f
|
||||
0.0 1.0 0.0 glVertex3f
|
||||
|
@ -52,23 +52,23 @@ M: nehe4-gadget draw-gadget* ( gadget -- )
|
|||
1.0 1.0 0.0 glVertex3f
|
||||
1.0 -1.0 0.0 glVertex3f
|
||||
-1.0 -1.0 0.0 glVertex3f
|
||||
] do-state
|
||||
] do-state
|
||||
dup nehe4-gadget-rtri 0.2 + over set-nehe4-gadget-rtri
|
||||
dup nehe4-gadget-rquad 0.15 - swap set-nehe4-gadget-rquad ;
|
||||
|
||||
: nehe4-update-thread ( gadget -- )
|
||||
dup nehe4-gadget-quit? [
|
||||
redraw-interval sleep
|
||||
dup relayout-1
|
||||
nehe4-update-thread
|
||||
] unless ;
|
||||
|
||||
: nehe4-update-thread ( gadget -- )
|
||||
dup nehe4-gadget-quit? [ drop ] [
|
||||
redraw-interval sleep
|
||||
dup relayout-1
|
||||
nehe4-update-thread
|
||||
] if ;
|
||||
|
||||
M: nehe4-gadget graft* ( gadget -- )
|
||||
[ f swap set-nehe4-gadget-quit? ] keep
|
||||
[ nehe4-update-thread ] in-thread drop ;
|
||||
[ f swap set-nehe4-gadget-quit? ] keep
|
||||
[ nehe4-update-thread ] in-thread drop ;
|
||||
|
||||
M: nehe4-gadget ungraft* ( gadget -- )
|
||||
t swap set-nehe4-gadget-quit? ;
|
||||
t swap set-nehe4-gadget-quit? ;
|
||||
|
||||
: run4 ( -- )
|
||||
<nehe4-gadget> "NeHe Tutorial 4" open-window ;
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2004 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: lazy-lists promises kernel sequences strings math
|
||||
arrays splitting quotations combinators ;
|
||||
arrays splitting quotations combinators namespaces ;
|
||||
IN: parser-combinators
|
||||
|
||||
! Parser combinator protocol
|
||||
|
@ -30,16 +30,32 @@ C: <parse-result> parse-result
|
|||
rot slice-seq <slice>
|
||||
] 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 )
|
||||
token-parser-string swap over ?head-slice [
|
||||
<parse-result> 1list
|
||||
] [
|
||||
2drop nil
|
||||
] if ;
|
||||
dup token-parser-string swap token-parser-ignore-case?
|
||||
>r tuck r> ?string-head
|
||||
[ <parse-result> 1list ] [ 2drop nil ] if ;
|
||||
|
||||
: 1token ( n -- parser ) 1string token ;
|
||||
|
||||
|
@ -224,7 +240,7 @@ LAZY: <*> ( parser -- parser )
|
|||
|
||||
LAZY: <?> ( parser -- parser )
|
||||
#! Return a parser that optionally uses the parser
|
||||
#! if that parser would be successfull.
|
||||
#! if that parser would be successful.
|
||||
[ 1array ] <@ f succeed <|> ;
|
||||
|
||||
TUPLE: only-first-parser p1 ;
|
||||
|
@ -261,6 +277,10 @@ LAZY: <!?> ( parser -- parser )
|
|||
#! required.
|
||||
<?> only-first ;
|
||||
|
||||
LAZY: <(?)> ( parser -- parser )
|
||||
#! Like <?> but take shortest match first.
|
||||
f succeed swap [ 1array ] <@ <|> ;
|
||||
|
||||
LAZY: <(*)> ( parser -- parser )
|
||||
#! Like <*> but take shortest match first.
|
||||
#! Implementation by Matthew Willis.
|
||||
|
@ -290,8 +310,13 @@ LAZY: <(+)> ( parser -- parser )
|
|||
LAZY: surrounded-by ( parser start end -- parser' )
|
||||
[ token ] 2apply swapd pack ;
|
||||
|
||||
: flatten* ( obj -- )
|
||||
dup array? [ [ flatten* ] each ] [ , ] if ;
|
||||
|
||||
: flatten [ flatten* ] { } make ;
|
||||
|
||||
: exactly-n ( parser n -- parser' )
|
||||
swap <repetition> <and-parser> ;
|
||||
swap <repetition> <and-parser> [ flatten ] <@ ;
|
||||
|
||||
: at-most-n ( parser n -- parser' )
|
||||
dup zero? [
|
||||
|
@ -305,4 +330,4 @@ LAZY: surrounded-by ( parser start end -- parser' )
|
|||
dupd exactly-n swap <*> <&> ;
|
||||
|
||||
: 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 <:&:> ;
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Gavin Harrison
|
|
@ -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 ;
|
|
@ -0,0 +1 @@
|
|||
Implementation of an embedded prolog for factor
|
|
@ -0,0 +1 @@
|
|||
prolog
|
|
@ -1,6 +1,6 @@
|
|||
USING: kernel math sequences namespaces hashtables words math.functions
|
||||
arrays parser compiler syntax io random prettyprint optimizer layouts
|
||||
inference math.constants random-tester.utils ;
|
||||
USING: kernel math sequences namespaces hashtables words
|
||||
arrays parser compiler syntax io prettyprint optimizer
|
||||
random math.constants math.functions layouts random-tester.utils ;
|
||||
IN: random-tester
|
||||
|
||||
! Tweak me
|
||||
|
@ -26,7 +26,7 @@ IN: random-tester
|
|||
{ } make \ special-floats set-global
|
||||
: 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 ,
|
||||
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> ,
|
||||
|
@ -34,16 +34,16 @@ IN: random-tester
|
|||
] { } make \ special-complexes set-global
|
||||
|
||||
: 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 )
|
||||
400 random-bits first-bignum + coin-flip [ neg ] when ;
|
||||
400 random-bits first-bignum + 50% [ neg ] when ;
|
||||
|
||||
: random-integer ( -- n )
|
||||
coin-flip [
|
||||
50% [
|
||||
random-fixnum
|
||||
] [
|
||||
coin-flip [ random-bignum ] [ special-integers random ] if
|
||||
50% [ random-bignum ] [ special-integers get random ] if
|
||||
] if ;
|
||||
|
||||
: random-positive-integer ( -- int )
|
||||
|
@ -54,12 +54,12 @@ IN: random-tester
|
|||
] if ;
|
||||
|
||||
: 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 )
|
||||
coin-flip [ random-ratio ] [ special-floats random ] if
|
||||
coin-flip
|
||||
[ .0000000000000000001 /f ] [ coin-flip [ .00000000000000001 * ] when ] if
|
||||
50% [ random-ratio ] [ special-floats get random ] if
|
||||
50%
|
||||
[ .0000000000000000001 /f ] [ 50% [ .00000000000000001 * ] when ] if
|
||||
>float ;
|
||||
|
||||
: random-number ( -- number )
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
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 ;
|
||||
IN: random-tester.utils
|
||||
|
||||
|
|
|
@ -1,174 +1,201 @@
|
|||
USING: regexp tools.test ;
|
||||
USING: regexp tools.test kernel ;
|
||||
IN: regexp-tests
|
||||
|
||||
[ f ] [ "b" "a*" matches? ] unit-test
|
||||
[ t ] [ "" "a*" matches? ] unit-test
|
||||
[ t ] [ "a" "a*" matches? ] unit-test
|
||||
[ t ] [ "aaaaaaa" "a*" matches? ] unit-test
|
||||
[ f ] [ "ab" "a*" matches? ] unit-test
|
||||
[ f ] [ "b" "a*" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "" "a*" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "a*" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "aaaaaaa" "a*" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "ab" "a*" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "abc" "abc" matches? ] unit-test
|
||||
[ t ] [ "a" "a|b|c" matches? ] unit-test
|
||||
[ t ] [ "b" "a|b|c" matches? ] unit-test
|
||||
[ t ] [ "c" "a|b|c" matches? ] unit-test
|
||||
[ f ] [ "c" "d|e|f" matches? ] unit-test
|
||||
[ t ] [ "abc" "abc" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "a|b|c" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "b" "a|b|c" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "c" "a|b|c" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "c" "d|e|f" f <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "aa" "a|b|c" matches? ] unit-test
|
||||
[ f ] [ "bb" "a|b|c" matches? ] unit-test
|
||||
[ f ] [ "cc" "a|b|c" matches? ] unit-test
|
||||
[ f ] [ "cc" "d|e|f" matches? ] unit-test
|
||||
[ f ] [ "aa" "a|b|c" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "bb" "a|b|c" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "cc" "a|b|c" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "cc" "d|e|f" f <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "" "a+" matches? ] unit-test
|
||||
[ t ] [ "a" "a+" matches? ] unit-test
|
||||
[ t ] [ "aa" "a+" matches? ] unit-test
|
||||
[ f ] [ "" "a+" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "a+" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "aa" "a+" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "" "a?" matches? ] unit-test
|
||||
[ t ] [ "a" "a?" matches? ] unit-test
|
||||
[ f ] [ "aa" "a?" matches? ] unit-test
|
||||
[ t ] [ "" "a?" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "a?" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "aa" "a?" f <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "" "." matches? ] unit-test
|
||||
[ t ] [ "a" "." matches? ] unit-test
|
||||
[ t ] [ "." "." matches? ] unit-test
|
||||
! [ f ] [ "\n" "." matches? ] unit-test
|
||||
[ f ] [ "" "." f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "." f <regexp> matches? ] unit-test
|
||||
[ t ] [ "." "." f <regexp> matches? ] unit-test
|
||||
! [ f ] [ "\n" "." f <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "" ".+" matches? ] unit-test
|
||||
[ t ] [ "a" ".+" matches? ] unit-test
|
||||
[ t ] [ "ab" ".+" matches? ] unit-test
|
||||
[ f ] [ "" ".+" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" ".+" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "ab" ".+" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "" "a|b*|c+|d?" matches? ] unit-test
|
||||
[ t ] [ "a" "a|b*|c+|d?" matches? ] unit-test
|
||||
[ t ] [ "c" "a|b*|c+|d?" matches? ] unit-test
|
||||
[ t ] [ "cc" "a|b*|c+|d?" matches? ] unit-test
|
||||
[ f ] [ "ccd" "a|b*|c+|d?" matches? ] unit-test
|
||||
[ t ] [ "d" "a|b*|c+|d?" matches? ] unit-test
|
||||
[ t ] [ "" "a|b*|c+|d?" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "a|b*|c+|d?" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "c" "a|b*|c+|d?" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "cc" "a|b*|c+|d?" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "ccd" "a|b*|c+|d?" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "d" "a|b*|c+|d?" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "foo" "foo|bar" matches? ] unit-test
|
||||
[ t ] [ "bar" "foo|bar" matches? ] unit-test
|
||||
[ f ] [ "foobar" "foo|bar" matches? ] unit-test
|
||||
[ t ] [ "foo" "foo|bar" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "bar" "foo|bar" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "foobar" "foo|bar" f <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "" "(a)" matches? ] unit-test
|
||||
[ t ] [ "a" "(a)" matches? ] unit-test
|
||||
[ f ] [ "aa" "(a)" matches? ] unit-test
|
||||
[ t ] [ "aa" "(a*)" matches? ] unit-test
|
||||
[ f ] [ "" "(a)" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "(a)" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "aa" "(a)" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "aa" "(a*)" f <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "aababaaabbac" "(a|b)+" matches? ] unit-test
|
||||
[ t ] [ "ababaaabba" "(a|b)+" matches? ] unit-test
|
||||
[ f ] [ "aababaaabbac" "(a|b)+" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "ababaaabba" "(a|b)+" f <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "" "a{1}" matches? ] unit-test
|
||||
[ t ] [ "a" "a{1}" matches? ] unit-test
|
||||
[ f ] [ "aa" "a{1}" matches? ] unit-test
|
||||
[ f ] [ "" "a{1}" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "a{1}" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "aa" "a{1}" f <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "a" "a{2,}" matches? ] unit-test
|
||||
[ t ] [ "aaa" "a{2,}" matches? ] unit-test
|
||||
[ t ] [ "aaaa" "a{2,}" matches? ] unit-test
|
||||
[ t ] [ "aaaaa" "a{2,}" matches? ] unit-test
|
||||
[ f ] [ "a" "a{2,}" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "aaa" "a{2,}" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "aaaa" "a{2,}" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "aaaaa" "a{2,}" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "" "a{,2}" matches? ] unit-test
|
||||
[ t ] [ "a" "a{,2}" matches? ] unit-test
|
||||
[ t ] [ "aa" "a{,2}" matches? ] unit-test
|
||||
[ f ] [ "aaa" "a{,2}" matches? ] unit-test
|
||||
[ f ] [ "aaaa" "a{,2}" matches? ] unit-test
|
||||
[ f ] [ "aaaaa" "a{,2}" matches? ] unit-test
|
||||
[ t ] [ "" "a{,2}" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "a{,2}" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "aa" "a{,2}" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "aaa" "a{,2}" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "aaaa" "a{,2}" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "aaaaa" "a{,2}" f <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "" "a{1,3}" matches? ] unit-test
|
||||
[ t ] [ "a" "a{1,3}" matches? ] unit-test
|
||||
[ t ] [ "aa" "a{1,3}" matches? ] unit-test
|
||||
[ t ] [ "aaa" "a{1,3}" matches? ] unit-test
|
||||
[ f ] [ "aaaa" "a{1,3}" matches? ] unit-test
|
||||
[ f ] [ "" "a{1,3}" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "a{1,3}" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "aa" "a{1,3}" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "aaa" "a{1,3}" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "aaaa" "a{1,3}" f <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "" "[a]" matches? ] unit-test
|
||||
[ t ] [ "a" "[a]" matches? ] unit-test
|
||||
[ t ] [ "a" "[abc]" matches? ] unit-test
|
||||
[ f ] [ "b" "[a]" matches? ] unit-test
|
||||
[ f ] [ "d" "[abc]" matches? ] unit-test
|
||||
[ t ] [ "ab" "[abc]{1,2}" matches? ] unit-test
|
||||
[ f ] [ "abc" "[abc]{1,2}" matches? ] unit-test
|
||||
[ f ] [ "" "[a]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[a]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[abc]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "b" "[a]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "d" "[abc]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "ab" "[abc]{1,2}" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "abc" "[abc]{1,2}" f <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "" "[^a]" matches? ] unit-test
|
||||
[ f ] [ "a" "[^a]" matches? ] unit-test
|
||||
[ f ] [ "a" "[^abc]" matches? ] unit-test
|
||||
[ t ] [ "b" "[^a]" matches? ] unit-test
|
||||
[ t ] [ "d" "[^abc]" matches? ] unit-test
|
||||
[ f ] [ "ab" "[^abc]{1,2}" matches? ] unit-test
|
||||
[ f ] [ "abc" "[^abc]{1,2}" matches? ] unit-test
|
||||
[ f ] [ "" "[^a]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "a" "[^a]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "a" "[^abc]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "b" "[^a]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "d" "[^abc]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "ab" "[^abc]{1,2}" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "abc" "[^abc]{1,2}" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "]" "[]]" matches? ] unit-test
|
||||
[ f ] [ "]" "[^]]" matches? ] unit-test
|
||||
[ t ] [ "]" "[]]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "]" "[^]]" f <regexp> matches? ] unit-test
|
||||
|
||||
! [ "^" "[^]" matches? ] unit-test-fails
|
||||
[ t ] [ "^" "[]^]" matches? ] unit-test
|
||||
[ t ] [ "]" "[]^]" matches? ] unit-test
|
||||
! [ "^" "[^]" f <regexp> matches? ] unit-test-fails
|
||||
[ t ] [ "^" "[]^]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "]" "[]^]" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "[" "[[]" matches? ] unit-test
|
||||
[ f ] [ "^" "[^^]" matches? ] unit-test
|
||||
[ t ] [ "a" "[^^]" matches? ] unit-test
|
||||
[ t ] [ "[" "[[]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "^" "[^^]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[^^]" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "-" "[-]" matches? ] unit-test
|
||||
[ f ] [ "a" "[-]" matches? ] unit-test
|
||||
[ f ] [ "-" "[^-]" matches? ] unit-test
|
||||
[ t ] [ "a" "[^-]" matches? ] unit-test
|
||||
[ t ] [ "-" "[-]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "a" "[-]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "-" "[^-]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[^-]" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "-" "[-a]" matches? ] unit-test
|
||||
[ t ] [ "a" "[-a]" matches? ] unit-test
|
||||
[ t ] [ "-" "[a-]" matches? ] unit-test
|
||||
[ t ] [ "a" "[a-]" matches? ] unit-test
|
||||
[ f ] [ "b" "[a-]" matches? ] unit-test
|
||||
[ f ] [ "-" "[^-]" matches? ] unit-test
|
||||
[ t ] [ "a" "[^-]" matches? ] unit-test
|
||||
[ t ] [ "-" "[-a]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[-a]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "-" "[a-]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[a-]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "b" "[a-]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "-" "[^-]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[^-]" f <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "-" "[a-c]" matches? ] unit-test
|
||||
[ t ] [ "-" "[^a-c]" matches? ] unit-test
|
||||
[ t ] [ "b" "[a-c]" matches? ] unit-test
|
||||
[ f ] [ "b" "[^a-c]" matches? ] unit-test
|
||||
[ f ] [ "-" "[a-c]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "-" "[^a-c]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "b" "[a-c]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "b" "[^a-c]" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "-" "[a-c-]" matches? ] unit-test
|
||||
[ f ] [ "-" "[^a-c-]" matches? ] unit-test
|
||||
[ t ] [ "-" "[a-c-]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "-" "[^a-c-]" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "\\" "[\\\\]" matches? ] unit-test
|
||||
[ f ] [ "a" "[\\\\]" matches? ] unit-test
|
||||
[ f ] [ "\\" "[^\\\\]" matches? ] unit-test
|
||||
[ t ] [ "a" "[^\\\\]" matches? ] unit-test
|
||||
[ t ] [ "\\" "[\\\\]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "a" "[\\\\]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "\\" "[^\\\\]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[^\\\\]" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "0" "[\\d]" matches? ] unit-test
|
||||
[ f ] [ "a" "[\\d]" matches? ] unit-test
|
||||
[ f ] [ "0" "[^\\d]" matches? ] unit-test
|
||||
[ t ] [ "a" "[^\\d]" matches? ] unit-test
|
||||
[ t ] [ "0" "[\\d]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "a" "[\\d]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "0" "[^\\d]" f <regexp> 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,2}|[A-Z]{3,3}|b*|c|(f|g)*" matches? ] unit-test
|
||||
[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}" 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)*" f <regexp> 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" "[0-9]{4,6}" matches? ] unit-test
|
||||
[ t ] [ "1000" "\\d{4,6}" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "1000" "[0-9]{4,6}" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "abc" "\\p{Lower}{3}" matches? ] unit-test
|
||||
[ f ] [ "ABC" "\\p{Lower}{3}" matches? ] unit-test
|
||||
[ t ] [ "ABC" "\\p{Upper}{3}" matches? ] unit-test
|
||||
[ f ] [ "abc" "\\p{Upper}{3}" matches? ] unit-test
|
||||
[ t ] [ "abc" "\\p{Lower}{3}" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "ABC" "\\p{Lower}{3}" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "ABC" "\\p{Upper}{3}" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "abc" "\\p{Upper}{3}" f <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "abc" "[\\p{Upper}]{3}" matches? ] unit-test
|
||||
[ t ] [ "ABC" "[\\p{Upper}]{3}" matches? ] unit-test
|
||||
[ f ] [ "abc" "[\\p{Upper}]{3}" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "ABC" "[\\p{Upper}]{3}" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "" "\\Q\\E" matches? ] unit-test
|
||||
[ f ] [ "a" "\\Q\\E" matches? ] unit-test
|
||||
[ t ] [ "|*+" "\\Q|*+\\E" matches? ] unit-test
|
||||
[ f ] [ "abc" "\\Q|*+\\E" matches? ] unit-test
|
||||
[ t ] [ "" "\\Q\\E" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "a" "\\Q\\E" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "|*+" "\\Q|*+\\E" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "abc" "\\Q|*+\\E" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "S" "\\0123" matches? ] unit-test
|
||||
[ t ] [ "SXY" "\\0123XY" matches? ] unit-test
|
||||
[ t ] [ "x" "\\x78" matches? ] unit-test
|
||||
[ f ] [ "y" "\\x78" matches? ] unit-test
|
||||
[ t ] [ "x" "\\u0078" matches? ] unit-test
|
||||
[ f ] [ "y" "\\u0078" matches? ] unit-test
|
||||
[ t ] [ "S" "\\0123" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "SXY" "\\0123XY" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "x" "\\x78" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "y" "\\x78" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "x" "\\u0078" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "y" "\\u0078" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "ab" "a+b" matches? ] unit-test
|
||||
[ f ] [ "b" "a+b" matches? ] unit-test
|
||||
[ t ] [ "aab" "a+b" matches? ] unit-test
|
||||
[ f ] [ "abb" "a+b" matches? ] unit-test
|
||||
[ t ] [ "ab" "a+b" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "b" "a+b" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "aab" "a+b" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "abb" "a+b" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "abbbb" "ab*" matches? ] unit-test
|
||||
[ t ] [ "a" "ab*" matches? ] unit-test
|
||||
[ f ] [ "abab" "ab*" matches? ] unit-test
|
||||
[ t ] [ "abbbb" "ab*" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "ab*" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "abab" "ab*" f <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "x" "\\." matches? ] unit-test
|
||||
[ t ] [ "." "\\." matches? ] unit-test
|
||||
[ f ] [ "x" "\\." f <regexp> 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
|
||||
|
|
|
@ -1,15 +1,36 @@
|
|||
USING: arrays combinators kernel lazy-lists math math.parser
|
||||
namespaces parser parser-combinators parser-combinators.simple
|
||||
promises quotations sequences combinators.lib strings macros
|
||||
promises quotations sequences combinators.lib strings
|
||||
assocs prettyprint.backend ;
|
||||
USE: io
|
||||
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 )
|
||||
[ \ dup add* ] map [ [ t ] ] f short-circuit \ nip add ;
|
||||
|
||||
MACRO: fast-member? ( str -- quot )
|
||||
[ dup ] H{ } map>assoc [ key? ] curry ;
|
||||
: <@literal [ nip ] curry <@ ;
|
||||
|
||||
: <@delay [ curry ] curry <@ ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: ascii? ( n -- ? )
|
||||
0 HEX: 7f between? ;
|
||||
|
||||
: octal-digit? ( n -- ? )
|
||||
CHAR: 0 CHAR: 7 between? ;
|
||||
|
@ -19,30 +40,32 @@ MACRO: fast-member? ( str -- quot )
|
|||
|
||||
: hex-digit? ( n -- ? )
|
||||
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 -- ? )
|
||||
dup 0 HEX: 1f between?
|
||||
swap HEX: 7f = or ;
|
||||
|
||||
: punct? ( n -- ? )
|
||||
"!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" fast-member? ;
|
||||
"!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ;
|
||||
|
||||
: c-identifier-char? ( ch -- ? )
|
||||
dup alpha? swap CHAR: _ = or ;
|
||||
|
||||
: java-blank? ( n -- ? )
|
||||
{
|
||||
CHAR: \s
|
||||
CHAR: \t CHAR: \n CHAR: \r
|
||||
HEX: c HEX: 7 HEX: 1b
|
||||
} fast-member? ;
|
||||
} member? ;
|
||||
|
||||
: java-printable? ( n -- ? )
|
||||
dup alpha? swap punct? or ;
|
||||
|
||||
: 'ordinary-char' ( -- parser )
|
||||
[ "\\^*+?|(){}[$" fast-member? not ] satisfy
|
||||
[ [ = ] curry ] <@ ;
|
||||
[ "\\^*+?|(){}[$" member? not ] satisfy
|
||||
[ char=-quot ] <@ ;
|
||||
|
||||
: 'octal-digit' ( -- parser ) [ octal-digit? ] satisfy ;
|
||||
|
||||
|
@ -58,7 +81,7 @@ MACRO: fast-member? ( str -- quot )
|
|||
[ hex> ] <@ ;
|
||||
|
||||
: 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 )
|
||||
{
|
||||
|
@ -69,7 +92,7 @@ MACRO: fast-member? ( str -- quot )
|
|||
{ "f" HEX: c }
|
||||
{ "a" HEX: 7 }
|
||||
{ "e" HEX: 1b }
|
||||
} [ [ = ] curry ] assoc-map satisfy-tokens ;
|
||||
} [ char=-quot ] assoc-map satisfy-tokens ;
|
||||
|
||||
: 'predefined-char-class' ( -- parser )
|
||||
{
|
||||
|
@ -85,7 +108,7 @@ MACRO: fast-member? ( str -- quot )
|
|||
{
|
||||
{ "Lower" [ letter? ] }
|
||||
{ "Upper" [ LETTER? ] }
|
||||
{ "ASCII" [ 0 HEX: 7f between? ] }
|
||||
{ "ASCII" [ ascii? ] }
|
||||
{ "Alpha" [ Letter? ] }
|
||||
{ "Digit" [ digit? ] }
|
||||
{ "Alnum" [ alpha? ] }
|
||||
|
@ -103,7 +126,7 @@ MACRO: fast-member? ( str -- quot )
|
|||
'hex' <|>
|
||||
"c" token [ LETTER? ] satisfy &> <|>
|
||||
any-char-parser <|>
|
||||
[ [ = ] curry ] <@ ;
|
||||
[ char=-quot ] <@ ;
|
||||
|
||||
: 'escape' ( -- parser )
|
||||
"\\" token
|
||||
|
@ -113,7 +136,7 @@ MACRO: fast-member? ( str -- quot )
|
|||
'simple-escape' <|> &> ;
|
||||
|
||||
: 'any-char'
|
||||
"." token [ drop [ drop t ] ] <@ ;
|
||||
"." token [ drop t ] <@literal ;
|
||||
|
||||
: 'char'
|
||||
'any-char' 'escape' 'ordinary-char' <|> <|> [ satisfy ] <@ ;
|
||||
|
@ -124,21 +147,24 @@ TUPLE: group-result str ;
|
|||
|
||||
C: <group-result> group-result
|
||||
|
||||
: 'grouping'
|
||||
: 'non-capturing-group' ( -- parser )
|
||||
'regexp' "(?:" ")" surrounded-by ;
|
||||
|
||||
: 'group' ( -- parser )
|
||||
'regexp' [ [ <group-result> ] <@ ] <@
|
||||
"(" ")" surrounded-by ;
|
||||
|
||||
: 'range' ( -- parser )
|
||||
any-char-parser "-" token <& any-char-parser <&>
|
||||
[ first2 [ between? ] 2curry ] <@ ;
|
||||
[ first2 char-between?-quot ] <@ ;
|
||||
|
||||
: 'character-class-term' ( -- parser )
|
||||
'range'
|
||||
'escape' <|>
|
||||
[ "\\]" member? not ] satisfy [ [ = ] curry ] <@ <|> ;
|
||||
[ "\\]" member? not ] satisfy [ char=-quot ] <@ <|> ;
|
||||
|
||||
: 'positive-character-class' ( -- parser )
|
||||
"]" token [ drop [ CHAR: ] = ] ] <@ 'character-class-term' <*> <&:>
|
||||
"]" token [ CHAR: ] = ] <@literal 'character-class-term' <*> <&:>
|
||||
'character-class-term' <+> <|>
|
||||
[ or-predicates ] <@ ;
|
||||
|
||||
|
@ -151,66 +177,101 @@ C: <group-result> group-result
|
|||
"[" "]" surrounded-by [ satisfy ] <@ ;
|
||||
|
||||
: '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 )
|
||||
'escaped-seq'
|
||||
'grouping' <|>
|
||||
'non-capturing-group' <|>
|
||||
'group' <|>
|
||||
'char' <|>
|
||||
'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 )
|
||||
'simple' 'integer' "{" "}" surrounded-by <&> [ first2 exactly-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 ] <@ <|> ;
|
||||
'exactly-n' 'at-least-n' <|> 'at-most-n' <|> 'from-m-to-n' <|> ;
|
||||
|
||||
: 'interval' ( -- parser )
|
||||
'greedy-interval'
|
||||
'greedy-interval' "?" token <& [ "reluctant {}" print ] <@ <|>
|
||||
'greedy-interval' "+" token <& [ "possessive {}" print ] <@ <|> ;
|
||||
|
||||
: 'greedy-repetition' ( -- parser )
|
||||
'simple' "*" token <& [ <*> ] <@
|
||||
'simple' "+" token <& [ <+> ] <@ <|>
|
||||
'simple' "?" token <& [ <?> ] <@ <|> ;
|
||||
'greedy-interval' "+" token <& [ "possessive {}" print ] <@ <|>
|
||||
"{" "}" surrounded-by ;
|
||||
|
||||
: 'repetition' ( -- parser )
|
||||
'greedy-repetition'
|
||||
'greedy-repetition' "?" token <& [ "reluctant" print ] <@ <|>
|
||||
'greedy-repetition' "+" token <& [ "possessive" print ] <@ <|> ;
|
||||
! Posessive
|
||||
"*+" token [ <!*> ] <@literal
|
||||
"++" token [ <!+> ] <@literal <|>
|
||||
"?+" token [ <!?> ] <@literal <|>
|
||||
! Reluctant
|
||||
"*?" token [ <(*)> ] <@literal <|>
|
||||
"+?" token [ <(+)> ] <@literal <|>
|
||||
"??" token [ <(?)> ] <@literal <|>
|
||||
! Greedy
|
||||
"*" token [ <*> ] <@literal <|>
|
||||
"+" token [ <+> ] <@literal <|>
|
||||
"?" token [ <?> ] <@literal <|> ;
|
||||
|
||||
: 'dummy' ( -- parser )
|
||||
epsilon [ ] <@literal ;
|
||||
|
||||
: 'term' ( -- parser )
|
||||
'simple' 'repetition' 'interval' <|> <|>
|
||||
<+> [ <and-parser> ] <@ ;
|
||||
'simple'
|
||||
'repetition' 'interval' 'dummy' <|> <|> <&> [ first2 call ] <@
|
||||
<!+> [ <and-parser> ] <@ ;
|
||||
|
||||
LAZY: 'regexp' ( -- parser )
|
||||
'term' "|" token nonempty-list-of [ <or-parser> ] <@
|
||||
"^" token 'term' "|" token nonempty-list-of [ <or-parser> ] <@
|
||||
&> [ "caret" print ] <@ <|>
|
||||
'term' "|" token nonempty-list-of [ <or-parser> ] <@
|
||||
"$" token <& [ "dollar" print ] <@ <|>
|
||||
"^" token 'term' "|" token nonempty-list-of [ <or-parser> ] <@ &>
|
||||
"$" token [ "caret dollar" print ] <@ <& <|> ;
|
||||
'term' "|" token nonempty-list-of [ <or-parser> ] <@ ;
|
||||
! "^" token 'term' "|" token nonempty-list-of [ <or-parser> ] <@
|
||||
! &> [ "caret" print ] <@ <|>
|
||||
! 'term' "|" token nonempty-list-of [ <or-parser> ] <@
|
||||
! "$" token <& [ "dollar" print ] <@ <|>
|
||||
! "^" token 'term' "|" token nonempty-list-of [ <or-parser> ] <@ &>
|
||||
! "$" 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 )
|
||||
|
||||
M: string >regexp <regexp> ;
|
||||
|
||||
M: object >regexp ;
|
||||
: do-ignore-case ( string regexp -- string regexp )
|
||||
dup regexp-ignore-case? [ >r >upper r> ] when ;
|
||||
|
||||
: 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
|
||||
: parse-options ( string -- ? )
|
||||
#! Lame
|
||||
{
|
||||
{ "" [ f ] }
|
||||
{ "i" [ t ] }
|
||||
} case ;
|
||||
|
||||
: parse-regexp ( accum end -- accum )
|
||||
lexer get dup skip-blank [
|
||||
[ 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
|
||||
|
@ -240,4 +301,9 @@ M: object >regexp ;
|
|||
} swap [ subseq? not nip ] curry assoc-find drop ;
|
||||
|
||||
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 ;
|
||||
|
|
|
@ -88,12 +88,15 @@ C: <entry> entry
|
|||
: simple-tag, ( content name -- )
|
||||
[ , ] tag, ;
|
||||
|
||||
: simple-tag*, ( content name attrs -- )
|
||||
[ , ] tag*, ;
|
||||
|
||||
: entry, ( entry -- )
|
||||
"entry" [
|
||||
dup entry-title "title" simple-tag,
|
||||
dup entry-title "title" { { "type" "html" } } simple-tag*,
|
||||
"link" over entry-link "href" associate contained*,
|
||||
dup entry-pub-date "published" simple-tag,
|
||||
entry-description [ "content" simple-tag, ] when*
|
||||
entry-description [ "content" { { "type" "html" } } simple-tag*, ] when*
|
||||
] tag, ;
|
||||
|
||||
: feed>xml ( feed -- xml )
|
||||
|
|
|
@ -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
|
||||
math math.vectors namespaces prettyprint sequences strings
|
||||
vectors words windows.kernel32 windows.gdi32 windows.user32
|
||||
windows.opengl32 windows.messages windows.types windows.nt
|
||||
windows threads timers libc combinators continuations
|
||||
windows.opengl32 windows.messages windows.types
|
||||
windows.nt windows threads timers libc combinators continuations
|
||||
command-line shuffle opengl ui.render ;
|
||||
IN: ui.windows
|
||||
|
||||
|
@ -257,14 +257,12 @@ M: windows-ui-backend (close-window)
|
|||
: prepare-mouse ( hWnd uMsg wParam lParam -- button coordinate world )
|
||||
nip >r mouse-event>gesture r> >lo-hi rot window ;
|
||||
|
||||
: mouse-captured? ( -- ? )
|
||||
mouse-captured get ;
|
||||
|
||||
: set-capture ( hwnd -- )
|
||||
mouse-captured get [
|
||||
drop
|
||||
] [
|
||||
[ SetCapture drop ] keep mouse-captured set
|
||||
[ SetCapture drop ] keep
|
||||
mouse-captured set
|
||||
] if ;
|
||||
|
||||
: release-capture ( -- )
|
||||
|
@ -276,7 +274,7 @@ M: windows-ui-backend (close-window)
|
|||
prepare-mouse send-button-down ;
|
||||
|
||||
: handle-wm-buttonup ( hWnd uMsg wParam lParam -- )
|
||||
mouse-captured? [ release-capture ] when
|
||||
mouse-captured get [ release-capture ] when
|
||||
prepare-mouse send-button-up ;
|
||||
|
||||
: make-TRACKMOUSEEVENT ( hWnd -- alien )
|
||||
|
@ -434,7 +432,7 @@ M: windows-ui-backend flush-gl-context ( handle -- )
|
|||
! Move window to front
|
||||
M: windows-ui-backend raise-window ( world -- )
|
||||
world-handle [
|
||||
win-hWnd SetFocus drop release-capture
|
||||
win-hWnd SetFocus drop
|
||||
] when* ;
|
||||
|
||||
M: windows-ui-backend set-title ( string world -- )
|
||||
|
|
|
@ -4,12 +4,17 @@
|
|||
USING: kernel furnace sqlite.tuple-db webapps.article-manager.database
|
||||
sequences namespaces math arrays assocs quotations io.files
|
||||
http.server http.basic-authentication http.server.responders
|
||||
webapps.file ;
|
||||
webapps.file html html.elements io ;
|
||||
IN: webapps.article-manager
|
||||
|
||||
: current-site ( -- 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 ;
|
||||
|
||||
C: <template-args> template-args
|
||||
|
|
|
@ -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 ; %>
|
||||
<div id="banner"><h1><% "arg1" get second article-title write %></h1></div>
|
||||
<% f "navigation" render-template %>
|
||||
<% "navigation" render-template %>
|
||||
<div id="article">
|
||||
<% 100 random 25 > [ "arg1" get first 100 random 50 > [ site-ad2 ] [ site-ad3 ] if write-html ] when %>
|
||||
<% "arg1" get second article-body write-html %>
|
||||
|
||||
<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>
|
||||
<p class="footer"></p>
|
||||
<p id="copyright"><% "arg1" get first site-footer write %></p>
|
||||
|
|
|
@ -6,7 +6,7 @@
|
|||
</head>
|
||||
<body>
|
||||
<div id="banner"><h1><% "title" get write %></h1></div>
|
||||
<% f "navigation" render-template %>
|
||||
<% "navigation" render-template %>
|
||||
<div id="article">
|
||||
<% "intro" get write-html %>
|
||||
<h1>Recent Articles</h1>
|
||||
|
@ -23,7 +23,7 @@
|
|||
but in the meantime, Google is likely to provide
|
||||
reasonable results.
|
||||
</p>
|
||||
<% host all-tags <template-args> "tags" render-template %>
|
||||
<% host all-tags <template-args> "tags" render-component %>
|
||||
</div>
|
||||
<p class="footer"></p>
|
||||
<p id="copyright"><% "footer" get write %></p>
|
||||
|
|
|
@ -5,5 +5,5 @@
|
|||
</ul>
|
||||
<% current-site site-ad1 write-html %>
|
||||
<h1>Tags</h1>
|
||||
<% host all-tags <template-args> "tags" render-template %>
|
||||
<% host all-tags <template-args> "tags" render-component %>
|
||||
</div>
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
<% USING: kernel io http.server namespaces sequences math html furnace webapps.article-manager.database webapps.article-manager html.elements ; %>
|
||||
|
||||
<div id="banner"><h1><% "arg1" get second tag-title write %></h1></div>
|
||||
<% f "navigation" render-template %>
|
||||
<% "navigation" render-component %>
|
||||
<div id="article">
|
||||
<h1><% "arg1" get second tag-title write %></h1>
|
||||
<% "arg1" get second tag-description write-html %>
|
||||
|
|
|
@ -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.
|
||||
USING: calendar html io io.files kernel math math.parser
|
||||
http.server.responders http.server.templating namespaces parser
|
||||
|
@ -31,15 +31,23 @@ IN: webapps.file
|
|||
"304 Not Modified" response
|
||||
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 -- )
|
||||
over last-modified-matches? [
|
||||
2drop not-modified-response
|
||||
] [
|
||||
dupd file-response
|
||||
"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 ;
|
||||
|
||||
|
@ -53,9 +61,13 @@ SYMBOL: page
|
|||
: include-page ( filename -- )
|
||||
"doc-root" get swap path+ run-page ;
|
||||
|
||||
: serve-fhtml ( filename -- )
|
||||
serving-html
|
||||
"method" get "head" = [ drop ] [ run-page ] if ;
|
||||
|
||||
: serve-file ( filename -- )
|
||||
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 -- )
|
||||
[ "/" append ] when
|
||||
|
@ -107,7 +119,7 @@ SYMBOL: page
|
|||
|
||||
global [
|
||||
! Serve up our own source code
|
||||
"resources" [
|
||||
"resources" [
|
||||
[
|
||||
"" resource-path "doc-root" set
|
||||
file-responder
|
||||
|
|
|
@ -4,7 +4,7 @@
|
|||
USING: kernel furnace fjsc parser-combinators namespaces
|
||||
lazy-lists io io.files furnace.validator sequences
|
||||
http.client http.server http.server.responders
|
||||
webapps.file ;
|
||||
webapps.file html ;
|
||||
IN: webapps.fjsc
|
||||
|
||||
: compile ( code -- )
|
||||
|
@ -31,6 +31,11 @@ IN: webapps.fjsc
|
|||
{ "url" v-required }
|
||||
} define-action
|
||||
|
||||
: render-page* ( model body-template head-template -- )
|
||||
[
|
||||
[ render-component ] [ f rot render-component ] html-document
|
||||
] serve-html ;
|
||||
|
||||
: repl ( -- )
|
||||
#! The main 'repl' page.
|
||||
f "repl" "head" render-page* ;
|
||||
|
|
|
@ -82,4 +82,4 @@ PREDICATE: pathname resource-pathname
|
|||
M: resource-pathname browser-link-href
|
||||
pathname-string
|
||||
"resource:" ?head drop
|
||||
"/responder/resources/" swap append ;
|
||||
"/responder/source/" swap append ;
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
<% USING: io math math.parser namespaces ; %>
|
||||
<% USING: io math math.parser namespaces furnace ; %>
|
||||
|
||||
<h1>Annotate</h1>
|
||||
|
||||
|
@ -9,17 +9,22 @@
|
|||
<input type="hidden" name="n" value="<% "n" get number>string write %>" />
|
||||
|
||||
<tr>
|
||||
<th>Your name:</th>
|
||||
<td><input type="TEXT" name="author" value="" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th>Summary:</th>
|
||||
<th align="right">Summary:</th>
|
||||
<td><input type="TEXT" name="summary" value="" /></td>
|
||||
</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>
|
||||
</tr>
|
||||
</table>
|
||||
|
|
|
@ -1,11 +1,11 @@
|
|||
<% USING: namespaces io ; %>
|
||||
<% USING: namespaces io furnace calendar ; %>
|
||||
|
||||
<h2>Annotation: <% "summary" get write %></h2>
|
||||
|
||||
<table>
|
||||
<tr><th>Annotation by:</th><td><% "author" 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>
|
||||
|
||||
<pre><% "contents" get write %></pre>
|
||||
<% "syntax" render-template %>
|
||||
|
|
|
@ -0,0 +1,3 @@
|
|||
</body>
|
||||
|
||||
</html>
|
|
@ -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>
|
|
@ -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>
|
|
@ -1,27 +1,41 @@
|
|||
<% USING: furnace namespaces ; %>
|
||||
|
||||
<%
|
||||
"New paste" "title" set
|
||||
"header" render-template
|
||||
%>
|
||||
|
||||
<form method="POST" action="/responder/pastebin/submit-paste">
|
||||
|
||||
<table>
|
||||
|
||||
<tr>
|
||||
<th>Your name:</th>
|
||||
<td><input type="TEXT" name="author" value="" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th>Summary:</th>
|
||||
<th align="right">Summary:</th>
|
||||
<td><input type="TEXT" name="summary" value="" /></td>
|
||||
</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>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th valign="top">Contents:</th>
|
||||
<th align="right" valign="top">Content:</th>
|
||||
<td><textarea rows="24" cols="60" name="contents"></textarea></td>
|
||||
</tr>
|
||||
</table>
|
||||
|
||||
<input type="SUBMIT" value="Submit paste" />
|
||||
</form>
|
||||
|
||||
<% "footer" render-template %>
|
||||
|
|
|
@ -1,7 +1,31 @@
|
|||
<% USING: namespaces furnace sequences ; %>
|
||||
|
||||
<table width="100%">
|
||||
<% "new-paste-quot" get "New paste" render-link %>
|
||||
<tr align="left"><th> </th><th>Summary:</th><th>Paste by:</th><th>Link</th><th>Date</th></tr>
|
||||
<% "pastes" get <reversed> [ "paste-summary" render-template ] each %></table>
|
||||
<%
|
||||
"Pastebin" "title" set
|
||||
"header" render-template
|
||||
%>
|
||||
|
||||
<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 %>
|
||||
|
|
|
@ -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>
|
||||
<td><% "n" get number>string write %></td>
|
||||
<td><% "summary" 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 print %></td>
|
||||
<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><% "date" get timestamp>string print %></td>
|
||||
</tr>
|
||||
|
|
|
@ -1,5 +1,6 @@
|
|||
USING: calendar furnace furnace.validator io.files kernel namespaces
|
||||
sequences store ;
|
||||
USING: calendar furnace furnace.validator io.files kernel
|
||||
namespaces sequences store http.server.responders html
|
||||
math.parser rss xml.writer ;
|
||||
IN: webapps.pastebin
|
||||
|
||||
TUPLE: pastebin pastes ;
|
||||
|
@ -7,23 +8,17 @@ TUPLE: pastebin pastes ;
|
|||
: <pastebin> ( -- pastebin )
|
||||
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 )
|
||||
V{ } clone
|
||||
{
|
||||
set-paste-summary
|
||||
set-paste-author
|
||||
set-paste-channel
|
||||
set-paste-contents
|
||||
set-paste-annotations
|
||||
} paste construct ;
|
||||
: <paste> ( summary author channel mode contents -- paste )
|
||||
f V{ } clone f paste construct-boa ;
|
||||
|
||||
TUPLE: annotation summary author contents ;
|
||||
TUPLE: annotation summary author mode contents ;
|
||||
|
||||
C: <annotation> annotation
|
||||
|
||||
|
||||
SYMBOL: store
|
||||
|
||||
"pastebin.store" resource-path load-store store set-global
|
||||
|
@ -34,49 +29,70 @@ SYMBOL: store
|
|||
pastebin get pastebin-pastes nth ;
|
||||
|
||||
: 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
|
||||
|
||||
: new-paste ( -- )
|
||||
f "new-paste" "New paste" render-page ;
|
||||
serving-html
|
||||
[ "new-paste" render-template ] with-html-stream ;
|
||||
|
||||
\ new-paste { } define-action
|
||||
|
||||
: paste-list ( -- )
|
||||
serving-html
|
||||
[
|
||||
[ show-paste ] "show-paste-quot" set
|
||||
[ new-paste ] "new-paste-quot" set
|
||||
pastebin get "paste-list" "Pastebin" render-page
|
||||
] with-scope ;
|
||||
pastebin get "paste-list" render-component
|
||||
] with-html-stream ;
|
||||
|
||||
\ 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 ( -- )
|
||||
store get-global save-store ;
|
||||
|
||||
: add-paste ( paste pastebin -- )
|
||||
>r now timestamp>http-string over set-paste-date r>
|
||||
pastebin-pastes
|
||||
[ length over set-paste-n ] keep push ;
|
||||
>r now over set-paste-date r>
|
||||
pastebin-pastes 2dup length swap set-paste-n push ;
|
||||
|
||||
: submit-paste ( summary author channel contents -- )
|
||||
<paste>
|
||||
\ pastebin get-global add-paste
|
||||
save-pastebin-store ;
|
||||
: submit-paste ( summary author channel mode contents -- )
|
||||
<paste> [
|
||||
\ pastebin get-global add-paste
|
||||
save-pastebin-store
|
||||
] keep paste-link permanent-redirect ;
|
||||
|
||||
\ submit-paste {
|
||||
{ "summary" v-required }
|
||||
{ "author" v-required }
|
||||
{ "channel" "#concatenative" v-default }
|
||||
{ "mode" "factor" v-default }
|
||||
{ "contents" v-required }
|
||||
} define-action
|
||||
|
||||
\ submit-paste [ paste-list ] define-redirect
|
||||
|
||||
: annotate-paste ( n summary author contents -- )
|
||||
: annotate-paste ( n summary author mode contents -- )
|
||||
<annotation> swap get-paste
|
||||
paste-annotations push
|
||||
save-pastebin-store ;
|
||||
|
@ -85,9 +101,16 @@ SYMBOL: store
|
|||
{ "n" v-required v-number }
|
||||
{ "summary" v-required }
|
||||
{ "author" v-required }
|
||||
{ "mode" "factor" v-default }
|
||||
{ "contents" v-required }
|
||||
} define-action
|
||||
|
||||
\ 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
|
||||
|
|
|
@ -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>
|
||||
<tr><th>Paste by:</th><td><% "author" 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>
|
||||
|
||||
<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 %>
|
||||
|
|
|
@ -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;
|
||||
}
|
|
@ -0,0 +1,3 @@
|
|||
<% USING: xmode.code2html splitting namespaces ; %>
|
||||
|
||||
<pre class="code"><% "contents" get string-lines "mode" get htmlize-lines %></pre>
|
|
@ -1,41 +1,14 @@
|
|||
USING: sequences rss arrays concurrency kernel sorting
|
||||
html.elements io assocs namespaces math threads vocabs html
|
||||
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
|
||||
|
||||
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 -- )
|
||||
<p "news" =class p>
|
||||
<b> dup posting-title write </b> <br/>
|
||||
"- " write
|
||||
dup posting-author write bl
|
||||
<a posting-link =href "more" =class a>
|
||||
<b> dup entry-title write </b> <br/>
|
||||
<a entry-link =href "more" =class a>
|
||||
"Read More..." write
|
||||
</a>
|
||||
</p> ;
|
||||
|
@ -51,70 +24,86 @@ TUPLE: posting author title date link body ;
|
|||
</ul> ;
|
||||
|
||||
: format-date ( date -- string )
|
||||
10 head "-" split [ string>number ] map
|
||||
first3 0 0 0 0 <timestamp>
|
||||
[
|
||||
dup timestamp-day #
|
||||
" " %
|
||||
dup timestamp-month month-abbreviations nth %
|
||||
", " %
|
||||
timestamp-year #
|
||||
] "" make ;
|
||||
rfc3339>timestamp timestamp>string ;
|
||||
|
||||
: print-posting ( posting -- )
|
||||
<h2 "posting-title" =class h2>
|
||||
<a dup posting-link =href a>
|
||||
dup posting-title write-html
|
||||
" - " write
|
||||
dup posting-author write
|
||||
<a dup entry-link =href a>
|
||||
dup entry-title write-html
|
||||
</a>
|
||||
</h2>
|
||||
<p "posting-body" =class p> dup posting-body write-html </p>
|
||||
<p "posting-date" =class p> posting-date format-date write </p> ;
|
||||
<p "posting-body" =class p>
|
||||
dup entry-description write-html
|
||||
</p>
|
||||
<p "posting-date" =class p>
|
||||
entry-pub-date format-date write
|
||||
</p> ;
|
||||
|
||||
: print-postings ( postings -- )
|
||||
[ print-posting ] each ;
|
||||
|
||||
: browse-webapp-source ( vocab -- )
|
||||
<a f >vocab-link browser-link-href =href a>
|
||||
"Browse source" write
|
||||
</a> ;
|
||||
|
||||
SYMBOL: default-blogroll
|
||||
SYMBOL: cached-postings
|
||||
|
||||
: update-cached-postings ( -- )
|
||||
default-blogroll get fetch-blogroll sort-entries
|
||||
[ <posting> ] map
|
||||
cached-postings set-global ;
|
||||
: safe-head ( seq n -- seq' )
|
||||
over length min head ;
|
||||
|
||||
: mini-planet-factor ( -- )
|
||||
cached-postings get 4 head print-posting-summaries ;
|
||||
cached-postings get 4 safe-head print-posting-summaries ;
|
||||
|
||||
: planet-factor ( -- )
|
||||
serving-html [
|
||||
"resource:extra/webapps/planet/planet.fhtml"
|
||||
run-template-file
|
||||
] with-html-stream ;
|
||||
serving-html [ "planet" render-template ] with-html-stream ;
|
||||
|
||||
\ planet-factor { } define-action
|
||||
|
||||
{
|
||||
{ "Berlin Brown" "http://factorlang-fornovices.blogspot.com/feeds/posts/default" "http://factorlang-fornovices.blogspot.com" }
|
||||
{ "Chris Double" "http://www.bluishcoder.co.nz/atom.xml" "http://www.bluishcoder.co.nz/" }
|
||||
{ "Elie Chaftari" "http://fun-factor.blogspot.com/feeds/posts/default" "http://fun-factor.blogspot.com/" }
|
||||
{ "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/" }
|
||||
{ "Kio M. Smallwood"
|
||||
"http://sekenre.wordpress.com/feed/atom/"
|
||||
"http://sekenre.wordpress.com/" }
|
||||
{ "Phil Dawes" "http://www.phildawes.net/blog/category/factor/feed/atom" "http://www.phildawes.net/blog/" }
|
||||
{ "Samuel Tardieu" "http://www.rfc1149.net/blog/tag/factor/feed/atom/" "http://www.rfc1149.net/blog/tag/factor/" }
|
||||
{ "Slava Pestov" "http://factor-language.blogspot.com/atom.xml" "http://factor-language.blogspot.com/" }
|
||||
} default-blogroll set-global
|
||||
: planet-feed ( -- feed )
|
||||
"[ planet-factor ]"
|
||||
"http://planet.factorcode.org"
|
||||
cached-postings get 30 safe-head <feed> ;
|
||||
|
||||
: feed.xml ( -- )
|
||||
"text/xml" serving-content
|
||||
planet-feed feed>xml write-xml ;
|
||||
|
||||
\ feed.xml { } define-action
|
||||
|
||||
: style.css ( -- )
|
||||
"text/css" serving-content
|
||||
"style.css" send-resource ;
|
||||
|
||||
\ style.css { } define-action
|
||||
|
||||
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 ( -- )
|
||||
millis last-update set-global
|
||||
[ update-cached-postings ] in-thread
|
||||
|
@ -126,14 +115,17 @@ SYMBOL: last-update
|
|||
|
||||
"planet" "planet-factor" "extra/webapps/planet" web-app
|
||||
|
||||
: merge-feeds ( feeds -- feed )
|
||||
[ feed-entries ] map concat sort-entries ;
|
||||
|
||||
: planet-feed ( -- feed )
|
||||
default-blogroll get [ second download-feed ] map merge-feeds
|
||||
>r "[ planet-factor ]" "http://planet.factorcode.org" r> <entry>
|
||||
feed>xml ;
|
||||
|
||||
: feed.xml planet-feed ;
|
||||
|
||||
\ feed.xml { } define-action
|
||||
{
|
||||
{ "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/" }
|
||||
{ "Elie Chaftari" "http://fun-factor.blogspot.com/feeds/posts/default" "http://fun-factor.blogspot.com/" }
|
||||
{ "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/" }
|
||||
{ "Gavin Harrison" "http://gmh33.blogspot.com/feeds/posts/default" "http://gmh33.blogspot.com/" }
|
||||
{ "Kio M. Smallwood"
|
||||
"http://sekenre.wordpress.com/feed/atom/"
|
||||
"http://sekenre.wordpress.com/" }
|
||||
{ "Phil Dawes" "http://www.phildawes.net/blog/category/factor/feed/atom" "http://www.phildawes.net/blog/" }
|
||||
{ "Samuel Tardieu" "http://www.rfc1149.net/blog/tag/factor/feed/atom/" "http://www.rfc1149.net/blog/tag/factor/" }
|
||||
{ "Slava Pestov" "http://factor-language.blogspot.com/atom.xml" "http://factor-language.blogspot.com/" }
|
||||
} default-blogroll set-global
|
||||
|
|
|
@ -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"
|
||||
"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" />
|
||||
|
||||
<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>
|
||||
|
||||
<body id="index">
|
||||
<h1 class="planet-title">[ planet-factor ]</h1>
|
||||
<table width="100%" cellpadding="10">
|
||||
<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">
|
||||
<p>
|
||||
<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>.
|
||||
</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 %>
|
||||
</p>
|
||||
<h2 class="blogroll-title">Blogroll</h2>
|
|
@ -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;
|
||||
}
|
|
@ -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
|
|
@ -1010,7 +1010,8 @@ FUNCTION: HANDLE GetStdHandle ( DWORD nStdHandle ) ;
|
|||
! FUNCTION: GetSystemDefaultLCID
|
||||
! FUNCTION: GetSystemDefaultUILanguage
|
||||
! FUNCTION: GetSystemDirectoryA
|
||||
! FUNCTION: GetSystemDirectoryW
|
||||
FUNCTION: UINT GetSystemDirectoryW ( LPTSTR lpBuffer, UINT uSize ) ;
|
||||
: GetSystemDirectory GetSystemDirectoryW ; inline
|
||||
FUNCTION: void GetSystemInfo ( LPSYSTEM_INFO lpSystemInfo ) ;
|
||||
! FUNCTION: GetSystemPowerStatus
|
||||
! FUNCTION: GetSystemRegistryQuota
|
||||
|
@ -1019,7 +1020,8 @@ FUNCTION: void GetSystemTime ( LPSYSTEMTIME lpSystemTime ) ;
|
|||
FUNCTION: void GetSystemTimeAsFileTime ( LPFILETIME lpSystemTimeAsFileTime ) ;
|
||||
! FUNCTION: GetSystemTimes
|
||||
! FUNCTION: GetSystemWindowsDirectoryA
|
||||
! FUNCTION: GetSystemWindowsDirectoryW
|
||||
FUNCTION: UINT GetSystemWindowsDirectoryW ( LPTSTR lpBuffer, UINT uSize ) ;
|
||||
: GetSystemWindowsDirectory GetSystemWindowsDirectoryW ; inline
|
||||
! FUNCTION: GetSystemWow64DirectoryA
|
||||
! FUNCTION: GetSystemWow64DirectoryW
|
||||
! FUNCTION: GetTapeParameters
|
||||
|
@ -1057,7 +1059,8 @@ FUNCTION: BOOL GetVersionExW ( LPOSVERSIONINFO lpVersionInfo ) ;
|
|||
! FUNCTION: GetVolumePathNamesForVolumeNameW
|
||||
! FUNCTION: GetVolumePathNameW
|
||||
! FUNCTION: GetWindowsDirectoryA
|
||||
! FUNCTION: GetWindowsDirectoryW
|
||||
FUNCTION: UINT GetWindowsDirectoryW ( LPTSTR lpBuffer, UINT uSize ) ;
|
||||
: GetWindowsDirectory GetWindowsDirectoryW ; inline
|
||||
! FUNCTION: GetWriteWatch
|
||||
! FUNCTION: GlobalAddAtomA
|
||||
! FUNCTION: GlobalAddAtomW
|
||||
|
|
|
@ -6,6 +6,7 @@ USING: alien sequences ;
|
|||
{ "kernel32" "kernel32.dll" "stdcall" }
|
||||
{ "winsock" "ws2_32.dll" "stdcall" }
|
||||
{ "mswsock" "mswsock.dll" "stdcall" }
|
||||
{ "shell32" "shell32.dll" "stdcall" }
|
||||
{ "libc" "msvcrt.dll" "cdecl" }
|
||||
{ "libm" "msvcrt.dll" "cdecl" }
|
||||
{ "gl" "opengl32.dll" "stdcall" }
|
||||
|
|
|
@ -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 ;
|
|
@ -7,6 +7,7 @@ IN: windows
|
|||
|
||||
: lo-word ( wparam -- lo ) <short> *short ; inline
|
||||
: hi-word ( wparam -- hi ) -16 shift lo-word ; inline
|
||||
: MAX_UNICODE_PATH 32768 ; inline
|
||||
|
||||
! You must LocalFree the return value!
|
||||
FUNCTION: void* error_message ( DWORD id ) ;
|
||||
|
|
|
@ -65,7 +65,6 @@ M: attrs set-at
|
|||
|
||||
M: attrs assoc-size length ;
|
||||
M: attrs new-assoc drop V{ } new <attrs> ;
|
||||
M: attrs assoc-find >r delegate r> assoc-find ;
|
||||
M: attrs >alist delegate >alist ;
|
||||
|
||||
: >attrs ( assoc -- attrs )
|
||||
|
|
|
@ -32,10 +32,10 @@ to depend on:
|
|||
it inherits the value of the NO_WORD_SEP attribute from the previous
|
||||
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
|
||||
between the Factor implementation and the original jEdit code, please
|
||||
report them as bugs. Also, if you wish to contribute a new or improved
|
||||
mode file, please contact the jEdit project. Updated mode files in jEdit
|
||||
will be periodically imported into the Factor source tree.
|
||||
If you wish to contribute a new or improved mode file, please contact
|
||||
the jEdit project. Updated mode files in jEdit will be periodically
|
||||
imported into the Factor source tree.
|
||||
|
|
|
@ -5,5 +5,7 @@ kernel sequences io ;
|
|||
[ 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
|
||||
|
|
|
@ -26,7 +26,7 @@ TAGS>
|
|||
"extra/xmode/modes/catalog" resource-path
|
||||
<file-reader> read-xml parse-modes-tag ;
|
||||
|
||||
: modes ( -- )
|
||||
: modes ( -- assoc )
|
||||
\ modes get-global [
|
||||
load-catalog dup \ modes set-global
|
||||
] unless* ;
|
||||
|
|
|
@ -15,8 +15,8 @@ IN: xmode.code2html
|
|||
: htmlize-line ( line-context line rules -- line-context' )
|
||||
tokenize-line htmlize-tokens ;
|
||||
|
||||
: htmlize-lines ( lines rules -- )
|
||||
<pre> f -rot [ htmlize-line nl ] curry each drop </pre> ;
|
||||
: htmlize-lines ( lines mode -- )
|
||||
f swap load-mode [ htmlize-line nl ] curry reduce drop ;
|
||||
|
||||
: default-stylesheet ( -- )
|
||||
<style>
|
||||
|
@ -24,22 +24,22 @@ IN: xmode.code2html
|
|||
resource-path <file-reader> contents write
|
||||
</style> ;
|
||||
|
||||
: htmlize-stream ( path stream -- )
|
||||
lines swap
|
||||
<html>
|
||||
<head>
|
||||
default-stylesheet
|
||||
<title> dup write </title>
|
||||
</head>
|
||||
<body>
|
||||
<pre>
|
||||
over empty?
|
||||
[ 2drop ]
|
||||
[ over first find-mode htmlize-lines ] if
|
||||
</pre>
|
||||
</body>
|
||||
</html> ;
|
||||
|
||||
: htmlize-file ( path -- )
|
||||
dup <file-reader> lines dup empty? [ 2drop ] [
|
||||
swap dup ".html" append <file-writer> [
|
||||
[
|
||||
<html>
|
||||
<head>
|
||||
<title> dup write </title>
|
||||
default-stylesheet
|
||||
</head>
|
||||
<body>
|
||||
over first
|
||||
find-mode
|
||||
load-mode
|
||||
htmlize-lines
|
||||
</body>
|
||||
</html>
|
||||
] with-html-stream
|
||||
] with-stream
|
||||
] if ;
|
||||
dup <file-reader> over ".html" append <file-writer>
|
||||
[ htmlize-stream ] with-stream ;
|
||||
|
|
|
@ -22,8 +22,6 @@ M: keyword-map set-at
|
|||
M: keyword-map clear-assoc
|
||||
[ delegate clear-assoc ] keep invalid-no-word-sep ;
|
||||
|
||||
M: keyword-map assoc-find >r delegate r> assoc-find ;
|
||||
|
||||
M: keyword-map >alist delegate >alist ;
|
||||
|
||||
: (keyword-map-no-word-sep)
|
||||
|
|
|
@ -1,11 +1,12 @@
|
|||
USING: xmode.tokens xmode.rules
|
||||
xmode.keyword-map xml.data xml.utilities xml assocs
|
||||
kernel combinators sequences math.parser namespaces parser
|
||||
xmode.utilities regexp io.files ;
|
||||
USING: xmode.tokens xmode.rules xmode.keyword-map xml.data
|
||||
xml.utilities xml assocs kernel combinators sequences
|
||||
math.parser namespaces parser xmode.utilities regexp io.files ;
|
||||
IN: xmode.loader
|
||||
|
||||
! Based on org.gjt.sp.jedit.XModeHandler
|
||||
|
||||
SYMBOL: ignore-case?
|
||||
|
||||
! Attribute utilities
|
||||
: string>boolean ( string -- ? ) "TRUE" = ;
|
||||
|
||||
|
@ -32,10 +33,13 @@ IN: xmode.loader
|
|||
swap [ at string>boolean ] curry map first3 ;
|
||||
|
||||
: 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 )
|
||||
dup children>string <regexp> swap position-attrs <matcher> ;
|
||||
dup children>string ignore-case? get <regexp>
|
||||
swap position-attrs <matcher> ;
|
||||
|
||||
! SPAN's children
|
||||
<TAGS: parse-begin/end-tag
|
||||
|
@ -130,22 +134,25 @@ RULE: MARK_FOLLOWING mark-following-rule
|
|||
RULE: MARK_PREVIOUS mark-previous-rule
|
||||
shared-tag-attrs match-type-attr literal-start ;
|
||||
|
||||
: parse-keyword-tag
|
||||
dup name-tag string>token swap children>string rot set-at ;
|
||||
: parse-keyword-tag ( tag keyword-map -- )
|
||||
>r dup name-tag string>token swap children>string r> set-at ;
|
||||
|
||||
TAG: KEYWORDS ( rule-set tag -- key value )
|
||||
>r rule-set-keywords r>
|
||||
child-tags [ parse-keyword-tag ] curry* each ;
|
||||
ignore-case? get <keyword-map>
|
||||
swap child-tags [ over parse-keyword-tag ] each
|
||||
swap set-rule-set-keywords ;
|
||||
|
||||
TAGS>
|
||||
|
||||
: ?<regexp> dup [ ignore-case? get <regexp> ] when ;
|
||||
|
||||
: (parse-rules-tag) ( tag -- rule-set )
|
||||
<rule-set>
|
||||
{
|
||||
{ "SET" string>rule-set-name set-rule-set-name }
|
||||
{ "IGNORE_CASE" string>boolean set-rule-set-ignore-case? }
|
||||
{ "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 }
|
||||
{ "DEFAULT" string>token set-rule-set-default }
|
||||
{ "NO_WORD_SEP" f set-rule-set-no-word-sep }
|
||||
|
@ -153,9 +160,9 @@ TAGS>
|
|||
|
||||
: parse-rules-tag ( tag -- rule-set )
|
||||
dup (parse-rules-tag) [
|
||||
swap child-tags [
|
||||
parse-rule-tag
|
||||
] curry* each
|
||||
dup rule-set-ignore-case? ignore-case? [
|
||||
swap child-tags [ parse-rule-tag ] curry* each
|
||||
] with-variable
|
||||
] keep ;
|
||||
|
||||
: merge-rule-set-props ( props rule-set -- )
|
||||
|
|
|
@ -109,3 +109,21 @@ IN: temporary
|
|||
] [
|
||||
f "$FOO" "shellscript" load-mode tokenize-line nip
|
||||
] 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
|
||||
|
|
|
@ -1,8 +1,8 @@
|
|||
IN: xmode.marker
|
||||
USING: kernel namespaces xmode.rules xmode.tokens
|
||||
xmode.marker.state xmode.marker.context
|
||||
xmode.utilities xmode.catalog sequences math
|
||||
assocs combinators combinators.lib strings regexp splitting ;
|
||||
xmode.marker.state xmode.marker.context xmode.utilities
|
||||
xmode.catalog sequences math assocs combinators combinators.lib
|
||||
strings regexp splitting parser-combinators ;
|
||||
|
||||
! Based on org.gjt.sp.jedit.syntax.TokenMarker
|
||||
|
||||
|
@ -15,8 +15,8 @@ assocs combinators combinators.lib strings regexp splitting ;
|
|||
[ dup [ digit? ] contains? ]
|
||||
[
|
||||
dup [ digit? ] all? [
|
||||
current-rule-set rule-set-digit-re dup
|
||||
[ dupd 2drop f ] [ drop f ] if
|
||||
current-rule-set rule-set-digit-re
|
||||
dup [ dupd matches? ] [ drop f ] if
|
||||
] unless*
|
||||
]
|
||||
} && nip ;
|
||||
|
@ -26,7 +26,7 @@ assocs combinators combinators.lib strings regexp splitting ;
|
|||
|
||||
: resolve-delegate ( name -- rules )
|
||||
dup string? [
|
||||
"::" split1 [ swap load-mode at ] [ rule-sets get at ] if*
|
||||
"::" split1 [ swap load-mode ] [ rule-sets get ] if* at
|
||||
] when ;
|
||||
|
||||
: rule-set-keyword-maps ( ruleset -- seq )
|
||||
|
@ -45,13 +45,6 @@ assocs combinators combinators.lib strings regexp splitting ;
|
|||
dup mark-number [ ] [ mark-keyword ] ?if
|
||||
[ prev-token, ] when* ;
|
||||
|
||||
: check-terminate-char ( -- )
|
||||
current-rule-set rule-set-terminate-char [
|
||||
position get <= [
|
||||
terminated? on
|
||||
] when
|
||||
] when* ;
|
||||
|
||||
: current-char ( -- char )
|
||||
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 ]
|
||||
} && 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?
|
||||
! XXX ignore case
|
||||
>r line get swap tail-slice r>
|
||||
[ head? ] keep length and ;
|
||||
M: f text-matches?
|
||||
2drop f ;
|
||||
|
||||
! 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 )
|
||||
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
|
||||
] if ;
|
||||
|
@ -92,8 +92,8 @@ M: string text-matches?
|
|||
dup rule-start swap can-match-here? 0 and
|
||||
] [
|
||||
dup rule-end tuck swap can-match-here? [
|
||||
position get swap matcher-text
|
||||
context get line-context-end or
|
||||
rest-of-line
|
||||
swap matcher-text context get line-context-end or
|
||||
text-matches?
|
||||
] [
|
||||
drop f
|
||||
|
@ -284,8 +284,6 @@ M: mark-previous-rule handle-rule-start
|
|||
|
||||
: mark-token-loop ( -- )
|
||||
position get line get length < [
|
||||
check-terminate-char
|
||||
|
||||
{
|
||||
[ check-end-delegate ]
|
||||
[ check-every-rule ]
|
||||
|
@ -302,8 +300,7 @@ M: mark-previous-rule handle-rule-start
|
|||
|
||||
: unwind-no-line-break ( -- )
|
||||
context get line-context-parent [
|
||||
line-context-in-rule rule-no-line-break?
|
||||
terminated? get or [
|
||||
line-context-in-rule rule-no-line-break? [
|
||||
pop-context
|
||||
unwind-no-line-break
|
||||
] when
|
||||
|
|
|
@ -16,7 +16,6 @@ SYMBOL: seen-whitespace-end?
|
|||
SYMBOL: escaped?
|
||||
SYMBOL: process-escape?
|
||||
SYMBOL: delegate-end-escaped?
|
||||
SYMBOL: terminated?
|
||||
|
||||
: current-rule ( -- rule )
|
||||
context get line-context-in-rule ;
|
||||
|
@ -52,10 +51,6 @@ SYMBOL: terminated?
|
|||
dup context set
|
||||
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 -- )
|
||||
rule-sets set
|
||||
line set
|
||||
|
|
|
@ -1,7 +1,11 @@
|
|||
USING: xmode.tokens xmode.keyword-map kernel
|
||||
sequences vectors assocs strings memoize ;
|
||||
sequences vectors assocs strings memoize regexp ;
|
||||
IN: xmode.rules
|
||||
|
||||
TUPLE: string-matcher string ignore-case? ;
|
||||
|
||||
C: <string-matcher> string-matcher
|
||||
|
||||
! Based on org.gjt.sp.jedit.syntax.ParserRuleSet
|
||||
TUPLE: rule-set
|
||||
name
|
||||
|
@ -20,12 +24,11 @@ no-word-sep
|
|||
|
||||
: init-rule-set ( ruleset -- )
|
||||
#! 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-props
|
||||
set-rule-set-imports
|
||||
set-rule-set-keywords
|
||||
} set-slots ;
|
||||
|
||||
: <rule-set> ( -- ruleset )
|
||||
|
@ -46,8 +49,9 @@ MEMO: standard-rule-set ( id -- ruleset )
|
|||
] when* ;
|
||||
|
||||
: rule-set-no-word-sep* ( ruleset -- str )
|
||||
dup rule-set-keywords keyword-map-no-word-sep*
|
||||
swap rule-set-no-word-sep "_" 3append ;
|
||||
dup rule-set-no-word-sep
|
||||
swap rule-set-keywords dup [ keyword-map-no-word-sep* ] when
|
||||
"_" 3append ;
|
||||
|
||||
! Match restrictions
|
||||
TUPLE: matcher text at-line-start? at-whitespace-end? at-word-start? ;
|
||||
|
@ -93,20 +97,32 @@ TUPLE: mark-previous-rule ;
|
|||
TUPLE: escape-rule ;
|
||||
|
||||
: <escape-rule> ( string -- rule )
|
||||
f f f <matcher>
|
||||
f <string-matcher> f f f <matcher>
|
||||
escape-rule construct-rule
|
||||
[ 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 )
|
||||
dup rule-chars
|
||||
swap rule-start matcher-text
|
||||
dup string? [ first add ] [ drop ] if ;
|
||||
text-hash-char [ add ] when* ;
|
||||
|
||||
: add-rule ( rule ruleset -- )
|
||||
>r dup rule-chars* >upper swap
|
||||
r> rule-set-rules inverted-index ;
|
||||
|
||||
: add-escape-rule ( string ruleset -- )
|
||||
>r <escape-rule> r>
|
||||
2dup set-rule-set-escape-rule
|
||||
add-rule ;
|
||||
over [
|
||||
>r <escape-rule> r>
|
||||
2dup set-rule-set-escape-rule
|
||||
add-rule
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
|
|
@ -57,7 +57,7 @@ check_installed_programs() {
|
|||
check_library_exists() {
|
||||
GCC_TEST=factor-library-test.c
|
||||
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
|
||||
gcc $GCC_TEST -o $GCC_OUT -l $1
|
||||
if [[ $? -ne 0 ]] ; then
|
||||
|
|
|
@ -2,7 +2,7 @@ USING: http.server help.markup help.syntax kernel prettyprint
|
|||
sequences parser namespaces words classes math tuples.private
|
||||
quotations arrays strings ;
|
||||
|
||||
IN: furnace
|
||||
IN: furnace.scaffold
|
||||
|
||||
TUPLE: furnace-model model ;
|
||||
C: <furnace-model> furnace-model
|
||||
|
@ -40,6 +40,11 @@ HELP: crud-lookup*
|
|||
{ $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." ;
|
||||
|
||||
: render-page ( model template title -- )
|
||||
[
|
||||
[ render-component ] simple-html-document
|
||||
] serve-html ;
|
||||
|
||||
: crud-page ( model template title -- )
|
||||
[ "libs/furnace/crud-templates" template-path set render-page ]
|
||||
with-scope ;
|
|
@ -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) \
|
||||
(((ucontext_t *)(ucontext))->uc_mcontext.gregs[16])
|
||||
|
|
|
@ -10,9 +10,9 @@ s64 current_millis(void)
|
|||
|
||||
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();
|
||||
|
||||
box_u16_string(buf);
|
||||
|
|
|
@ -70,7 +70,6 @@
|
|||
#elif defined(FACTOR_ARM)
|
||||
#include "os-linux-arm.h"
|
||||
#elif defined(FACTOR_AMD64)
|
||||
#include "os-unix-ucontext.h"
|
||||
#include "os-linux-x86-64.h"
|
||||
#else
|
||||
#error "Unsupported Linux flavor"
|
||||
|
|
Loading…
Reference in New Issue