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

Conflicts:

	extra/random-tester/random/random.factor
	extra/random-tester/utils/utils.factor
release
Daniel Ehrenberg 2007-12-09 02:11:26 -05:00
commit 717ea6206a
84 changed files with 1317 additions and 563 deletions

View File

@ -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 ;

View File

@ -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 -- )

View File

@ -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

View File

@ -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

View File

@ -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 ;

View 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? [

View File

@ -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 )

View File

@ -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* ;

View File

@ -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 )
[

View File

@ -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:

View File

@ -0,0 +1 @@
Doug Coleman

View File

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

View File

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

View File

@ -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> ;

View File

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

View File

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

View File

@ -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

View File

@ -235,6 +235,7 @@ ARTICLE: "changes" "Changes in the latest release"
{ "New, efficient implementations of " { $link bit? } " and " { $link log2 } " runs in constant time for large bignums" }
{ "New " { $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" }

View File

@ -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 )
[

View File

@ -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"
} ;

View File

@ -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 -- )

View File

@ -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 ;

View File

@ -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

View File

@ -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 ;

View File

@ -4,13 +4,23 @@ USING: alien alien.c-types arrays destructors io io.backend
io.buffers io.files io.nonblocking io.sockets io.binary
io.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

View File

@ -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 ;

View File

@ -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 <:&:> ;

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

@ -0,0 +1 @@
Gavin Harrison

View File

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

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

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

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

@ -0,0 +1 @@
prolog

View File

@ -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 )

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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 )

View File

@ -4,8 +4,8 @@ USING: alien alien.c-types arrays assocs ui ui.gadgets
ui.backend ui.clipboards ui.gadgets.worlds ui.gestures io kernel
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 -- )

View File

@ -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

View File

@ -1,12 +1,12 @@
<% USING: kernel io http.server namespaces sequences math html.elements random furnace webapps.article-manager webapps.article-manager.database html.elements ; %>
<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>

View File

@ -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>

View File

@ -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>

View File

@ -1,7 +1,7 @@
<% USING: kernel io http.server namespaces sequences math html furnace webapps.article-manager.database webapps.article-manager html.elements ; %>
<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 %>

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

@ -1,4 +1,4 @@
! Copyright (C) 2004, 2006 Slava Pestov.
! Copyright (C) 2004, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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

View File

@ -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* ;

View File

@ -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 ;

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

@ -1,4 +1,4 @@
<% USING: io math math.parser namespaces ; %>
<% USING: io math math.parser namespaces furnace ; %>
<h1>Annotate</h1>
@ -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>

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

@ -1,11 +1,11 @@
<% USING: namespaces io ; %>
<% USING: namespaces io furnace calendar ; %>
<h2>Annotation: <% "summary" get write %></h2>
<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 %>

View File

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

View File

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

View File

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

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

@ -1,27 +1,41 @@
<% USING: furnace namespaces ; %>
<%
"New paste" "title" set
"header" render-template
%>
<form method="POST" action="/responder/pastebin/submit-paste">
<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 %>

View File

@ -1,7 +1,31 @@
<% USING: namespaces furnace sequences ; %>
<table width="100%">
<% "new-paste-quot" get "New paste" render-link %>
<tr align="left"><th>&nbsp;</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 %>

View File

@ -1,9 +1,16 @@
<% USING: continuations namespaces io kernel math math.parser furnace ; %>
<% USING: continuations namespaces io kernel math math.parser
furnace webapps.pastebin calendar sequences ; %>
<tr>
<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>

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

@ -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

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

@ -1,15 +1,21 @@
<% USING: namespaces io furnace sequences ; %>
<% USING: namespaces io furnace sequences xmode.code2html calendar ; %>
<h1>Paste: <% "summary" get write %></h1>
<%
"Paste: " "summary" get append "title" set
"header" render-template
%>
<table>
<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 %>

View File

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

View File

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

View File

@ -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

View File

@ -1,4 +1,5 @@
<% USING: namespaces html.elements webapps.planet sequences ; %>
<% USING: namespaces html.elements webapps.planet sequences
furnace ; %>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
"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>

View File

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

View File

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

View File

@ -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

View File

@ -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" }

View File

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

View File

@ -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 ) ;

View File

@ -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 )

View File

@ -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.

View File

@ -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

View File

@ -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* ;

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

@ -15,8 +15,8 @@ IN: xmode.code2html
: htmlize-line ( line-context line rules -- line-context' )
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 ;

View File

@ -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)

View File

@ -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 -- )

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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 ;

View File

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

View File

@ -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);

View File

@ -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"