diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 0e214c412a..2c418768c6 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -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 ; diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 76b4d49636..f80a00855d 100644 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -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 -- ) diff --git a/core/compiler/test/curry.factor b/core/compiler/test/curry.factor index 307c8adcdb..0e840154ca 100755 --- a/core/compiler/test/curry.factor +++ b/core/compiler/test/curry.factor @@ -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 diff --git a/core/compiler/test/simple.factor b/core/compiler/test/simple.factor index 594bb844a1..cc446dee23 100644 --- a/core/compiler/test/simple.factor +++ b/core/compiler/test/simple.factor @@ -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 diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 1dd4259bb6..03bcb77731 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -126,3 +126,17 @@ TUPLE: pathname string ; C: 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 ; diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index 40752c58a5..e9e4c53632 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -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 and 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? [ diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index 0ea1f1316b..3389b1b84e 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -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 ) diff --git a/extra/benchmark/reverse-complement/reverse-complement.factor b/extra/benchmark/reverse-complement/reverse-complement.factor index 7de7ec24b4..4da3972e34 100644 --- a/extra/benchmark/reverse-complement/reverse-complement.factor +++ b/extra/benchmark/reverse-complement/reverse-complement.factor @@ -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* ; diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index c255e0a78e..55d632d245 100644 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -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 ; + +: rfc3339>timestamp ( str -- timestamp ) + [ + (rfc3339>timestamp) + ] string-in ; : file-time-string ( timestamp -- string ) [ diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 8dc3e3720e..5614296305 100644 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -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 spin define-method ] [ 3drop ] if* + pick "methods" word-prop at dup + [ method-def spin define-method ] [ 3drop ] if ] 2curry each ; : MIMIC: diff --git a/extra/editors/wordpad/authors.txt b/extra/editors/wordpad/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/editors/wordpad/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/editors/wordpad/summary.txt b/extra/editors/wordpad/summary.txt new file mode 100644 index 0000000000..016c602e75 --- /dev/null +++ b/extra/editors/wordpad/summary.txt @@ -0,0 +1 @@ +Wordpad editor integration diff --git a/extra/editors/wordpad/wordpad.factor b/extra/editors/wordpad/wordpad.factor new file mode 100644 index 0000000000..e1646a0855 --- /dev/null +++ b/extra/editors/wordpad/wordpad.factor @@ -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 diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index f2ce0ddf18..756fa13d1c 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -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 + 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 [ write 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 -- ) + vocab-link browser-link-href =href a> + "Browse source" write + ; diff --git a/extra/hardware-info/windows/ce/ce.factor b/extra/hardware-info/windows/ce/ce.factor index 1ae908c6ef..42fd9e5343 100644 --- a/extra/hardware-info/windows/ce/ce.factor +++ b/extra/hardware-info/windows/ce/ce.factor @@ -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 ) diff --git a/extra/hardware-info/windows/nt/nt.factor b/extra/hardware-info/windows/nt/nt.factor index fafcb58dca..2b2522e6ee 100644 --- a/extra/hardware-info/windows/nt/nt.factor +++ b/extra/hardware-info/windows/nt/nt.factor @@ -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 ) diff --git a/extra/hardware-info/windows/windows.factor b/extra/hardware-info/windows/windows.factor index bbae541ab4..88e9a8cfb5 100644 --- a/extra/hardware-info/windows/windows.factor +++ b/extra/hardware-info/windows/windows.factor @@ -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? ; +: ( n -- obj ) + "ushort" ; + +: get-directory ( word -- str ) + >r MAX_UNICODE_PATH [ ] 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 diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index ef25e91191..30f8d0f29f 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -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" } diff --git a/extra/http/http.factor b/extra/http/http.factor index a358c449af..f6ea3d699f 100644 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -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 ) [ diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index f9d642d661..8f1d05876d 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -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" + } ; diff --git a/extra/io/windows/ce/files/files.factor b/extra/io/windows/ce/files/files.factor index df5dc65094..c4f5b2ef9e 100755 --- a/extra/io/windows/ce/files/files.factor +++ b/extra/io/windows/ce/files/files.factor @@ -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 -- ) diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 31893fab0c..136c8197fc 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -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 ; diff --git a/extra/io/windows/mmap/mmap.factor b/extra/io/windows/mmap/mmap.factor index ca5d2bbd9a..27587e8340 100755 --- a/extra/io/windows/mmap/mmap.factor +++ b/extra/io/windows/mmap/mmap.factor @@ -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 diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index d53f5fcb40..5eed39224c 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -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 ; diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 53ee82ed65..2defa48298 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -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 ; : ( in out -- stream ) >r f r> f 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 FILE_BEGIN SetFilePointer diff --git a/extra/nehe/4/4.factor b/extra/nehe/4/4.factor index 39bf9841fd..b87b4a2308 100644 --- a/extra/nehe/4/4.factor +++ b/extra/nehe/4/4.factor @@ -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 ( -- ) "NeHe Tutorial 4" open-window ; diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index 874dedeb6f..2a5d6a2c2b 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -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 rot slice-seq ] 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 ( string -- parser ) f ; + +: case-insensitive-token ( string -- parser ) t ; M: token-parser parse ( input parser -- list ) - token-parser-string swap over ?head-slice [ - 1list - ] [ - 2drop nil - ] if ; + dup token-parser-string swap token-parser-ignore-case? + >r tuck r> ?string-head + [ 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 ; + swap [ 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 <:&:> ; diff --git a/extra/prolog/authors.txt b/extra/prolog/authors.txt new file mode 100644 index 0000000000..194cb22416 --- /dev/null +++ b/extra/prolog/authors.txt @@ -0,0 +1 @@ +Gavin Harrison diff --git a/extra/prolog/prolog.factor b/extra/prolog/prolog.factor new file mode 100644 index 0000000000..0a6a513b97 --- /dev/null +++ b/extra/prolog/prolog.factor @@ -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 ; diff --git a/extra/prolog/summary.txt b/extra/prolog/summary.txt new file mode 100644 index 0000000000..48ad1f312e --- /dev/null +++ b/extra/prolog/summary.txt @@ -0,0 +1 @@ +Implementation of an embedded prolog for factor diff --git a/extra/prolog/tags.txt b/extra/prolog/tags.txt new file mode 100644 index 0000000000..458345b533 --- /dev/null +++ b/extra/prolog/tags.txt @@ -0,0 +1 @@ +prolog diff --git a/extra/random-tester/random/random.factor b/extra/random-tester/random/random.factor index 7b7b4dfb6e..163de69a59 100755 --- a/extra/random-tester/random/random.factor +++ b/extra/random-tester/random/random.factor @@ -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 ) diff --git a/extra/random-tester/utils/utils.factor b/extra/random-tester/utils/utils.factor index 3bc8184e5e..a025bbf45f 100644 --- a/extra/random-tester/utils/utils.factor +++ b/extra/random-tester/utils/utils.factor @@ -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 diff --git a/extra/regexp/regexp-tests.factor b/extra/regexp/regexp-tests.factor index 5cec0af0a9..d76b038ffa 100755 --- a/extra/regexp/regexp-tests.factor +++ b/extra/regexp/regexp-tests.factor @@ -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 matches? ] unit-test +[ t ] [ "" "a*" f matches? ] unit-test +[ t ] [ "a" "a*" f matches? ] unit-test +[ t ] [ "aaaaaaa" "a*" f matches? ] unit-test +[ f ] [ "ab" "a*" f 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 matches? ] unit-test +[ t ] [ "a" "a|b|c" f matches? ] unit-test +[ t ] [ "b" "a|b|c" f matches? ] unit-test +[ t ] [ "c" "a|b|c" f matches? ] unit-test +[ f ] [ "c" "d|e|f" f matches? ] unit-test -[ f ] [ "aa" "a|b|c" matches? ] unit-test -[ f ] [ "bb" "a|b|c" matches? ] unit-test -[ f ] [ "cc" "a|b|c" matches? ] unit-test -[ f ] [ "cc" "d|e|f" matches? ] unit-test +[ f ] [ "aa" "a|b|c" f matches? ] unit-test +[ f ] [ "bb" "a|b|c" f matches? ] unit-test +[ f ] [ "cc" "a|b|c" f matches? ] unit-test +[ f ] [ "cc" "d|e|f" f matches? ] unit-test -[ f ] [ "" "a+" matches? ] unit-test -[ t ] [ "a" "a+" matches? ] unit-test -[ t ] [ "aa" "a+" matches? ] unit-test +[ f ] [ "" "a+" f matches? ] unit-test +[ t ] [ "a" "a+" f matches? ] unit-test +[ t ] [ "aa" "a+" f matches? ] unit-test -[ t ] [ "" "a?" matches? ] unit-test -[ t ] [ "a" "a?" matches? ] unit-test -[ f ] [ "aa" "a?" matches? ] unit-test +[ t ] [ "" "a?" f matches? ] unit-test +[ t ] [ "a" "a?" f matches? ] unit-test +[ f ] [ "aa" "a?" f matches? ] unit-test -[ f ] [ "" "." matches? ] unit-test -[ t ] [ "a" "." matches? ] unit-test -[ t ] [ "." "." matches? ] unit-test -! [ f ] [ "\n" "." matches? ] unit-test +[ f ] [ "" "." f matches? ] unit-test +[ t ] [ "a" "." f matches? ] unit-test +[ t ] [ "." "." f matches? ] unit-test +! [ f ] [ "\n" "." f matches? ] unit-test -[ f ] [ "" ".+" matches? ] unit-test -[ t ] [ "a" ".+" matches? ] unit-test -[ t ] [ "ab" ".+" matches? ] unit-test +[ f ] [ "" ".+" f matches? ] unit-test +[ t ] [ "a" ".+" f matches? ] unit-test +[ t ] [ "ab" ".+" f 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 matches? ] unit-test +[ t ] [ "a" "a|b*|c+|d?" f matches? ] unit-test +[ t ] [ "c" "a|b*|c+|d?" f matches? ] unit-test +[ t ] [ "cc" "a|b*|c+|d?" f matches? ] unit-test +[ f ] [ "ccd" "a|b*|c+|d?" f matches? ] unit-test +[ t ] [ "d" "a|b*|c+|d?" f 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 matches? ] unit-test +[ t ] [ "bar" "foo|bar" f matches? ] unit-test +[ f ] [ "foobar" "foo|bar" f 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 matches? ] unit-test +[ t ] [ "a" "(a)" f matches? ] unit-test +[ f ] [ "aa" "(a)" f matches? ] unit-test +[ t ] [ "aa" "(a*)" f matches? ] unit-test -[ f ] [ "aababaaabbac" "(a|b)+" matches? ] unit-test -[ t ] [ "ababaaabba" "(a|b)+" matches? ] unit-test +[ f ] [ "aababaaabbac" "(a|b)+" f matches? ] unit-test +[ t ] [ "ababaaabba" "(a|b)+" f 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 matches? ] unit-test +[ t ] [ "a" "a{1}" f matches? ] unit-test +[ f ] [ "aa" "a{1}" f 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 matches? ] unit-test +[ t ] [ "aaa" "a{2,}" f matches? ] unit-test +[ t ] [ "aaaa" "a{2,}" f matches? ] unit-test +[ t ] [ "aaaaa" "a{2,}" f 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 matches? ] unit-test +[ t ] [ "a" "a{,2}" f matches? ] unit-test +[ t ] [ "aa" "a{,2}" f matches? ] unit-test +[ f ] [ "aaa" "a{,2}" f matches? ] unit-test +[ f ] [ "aaaa" "a{,2}" f matches? ] unit-test +[ f ] [ "aaaaa" "a{,2}" f 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 matches? ] unit-test +[ t ] [ "a" "a{1,3}" f matches? ] unit-test +[ t ] [ "aa" "a{1,3}" f matches? ] unit-test +[ t ] [ "aaa" "a{1,3}" f matches? ] unit-test +[ f ] [ "aaaa" "a{1,3}" f 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 matches? ] unit-test +[ t ] [ "a" "[a]" f matches? ] unit-test +[ t ] [ "a" "[abc]" f matches? ] unit-test +[ f ] [ "b" "[a]" f matches? ] unit-test +[ f ] [ "d" "[abc]" f matches? ] unit-test +[ t ] [ "ab" "[abc]{1,2}" f matches? ] unit-test +[ f ] [ "abc" "[abc]{1,2}" f 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 matches? ] unit-test +[ f ] [ "a" "[^a]" f matches? ] unit-test +[ f ] [ "a" "[^abc]" f matches? ] unit-test +[ t ] [ "b" "[^a]" f matches? ] unit-test +[ t ] [ "d" "[^abc]" f matches? ] unit-test +[ f ] [ "ab" "[^abc]{1,2}" f matches? ] unit-test +[ f ] [ "abc" "[^abc]{1,2}" f matches? ] unit-test -[ t ] [ "]" "[]]" matches? ] unit-test -[ f ] [ "]" "[^]]" matches? ] unit-test +[ t ] [ "]" "[]]" f matches? ] unit-test +[ f ] [ "]" "[^]]" f matches? ] unit-test -! [ "^" "[^]" matches? ] unit-test-fails -[ t ] [ "^" "[]^]" matches? ] unit-test -[ t ] [ "]" "[]^]" matches? ] unit-test +! [ "^" "[^]" f matches? ] unit-test-fails +[ t ] [ "^" "[]^]" f matches? ] unit-test +[ t ] [ "]" "[]^]" f matches? ] unit-test -[ t ] [ "[" "[[]" matches? ] unit-test -[ f ] [ "^" "[^^]" matches? ] unit-test -[ t ] [ "a" "[^^]" matches? ] unit-test +[ t ] [ "[" "[[]" f matches? ] unit-test +[ f ] [ "^" "[^^]" f matches? ] unit-test +[ t ] [ "a" "[^^]" f matches? ] unit-test -[ t ] [ "-" "[-]" matches? ] unit-test -[ f ] [ "a" "[-]" matches? ] unit-test -[ f ] [ "-" "[^-]" matches? ] unit-test -[ t ] [ "a" "[^-]" matches? ] unit-test +[ t ] [ "-" "[-]" f matches? ] unit-test +[ f ] [ "a" "[-]" f matches? ] unit-test +[ f ] [ "-" "[^-]" f matches? ] unit-test +[ t ] [ "a" "[^-]" f 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 matches? ] unit-test +[ t ] [ "a" "[-a]" f matches? ] unit-test +[ t ] [ "-" "[a-]" f matches? ] unit-test +[ t ] [ "a" "[a-]" f matches? ] unit-test +[ f ] [ "b" "[a-]" f matches? ] unit-test +[ f ] [ "-" "[^-]" f matches? ] unit-test +[ t ] [ "a" "[^-]" f 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 matches? ] unit-test +[ t ] [ "-" "[^a-c]" f matches? ] unit-test +[ t ] [ "b" "[a-c]" f matches? ] unit-test +[ f ] [ "b" "[^a-c]" f matches? ] unit-test -[ t ] [ "-" "[a-c-]" matches? ] unit-test -[ f ] [ "-" "[^a-c-]" matches? ] unit-test +[ t ] [ "-" "[a-c-]" f matches? ] unit-test +[ f ] [ "-" "[^a-c-]" f matches? ] unit-test -[ t ] [ "\\" "[\\\\]" matches? ] unit-test -[ f ] [ "a" "[\\\\]" matches? ] unit-test -[ f ] [ "\\" "[^\\\\]" matches? ] unit-test -[ t ] [ "a" "[^\\\\]" matches? ] unit-test +[ t ] [ "\\" "[\\\\]" f matches? ] unit-test +[ f ] [ "a" "[\\\\]" f matches? ] unit-test +[ f ] [ "\\" "[^\\\\]" f matches? ] unit-test +[ t ] [ "a" "[^\\\\]" f 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 matches? ] unit-test +[ f ] [ "a" "[\\d]" f matches? ] unit-test +[ f ] [ "0" "[^\\d]" f matches? ] unit-test +[ t ] [ "a" "[^\\d]" f 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 matches? ] unit-test +[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}|b*|c|(f|g)*" f matches? ] unit-test +[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}" f 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 matches? ] unit-test +[ t ] [ "1000" "[0-9]{4,6}" f 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 matches? ] unit-test +[ f ] [ "ABC" "\\p{Lower}{3}" f matches? ] unit-test +[ t ] [ "ABC" "\\p{Upper}{3}" f matches? ] unit-test +[ f ] [ "abc" "\\p{Upper}{3}" f 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 matches? ] unit-test +[ t ] [ "ABC" "[\\p{Upper}]{3}" f 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 matches? ] unit-test +[ f ] [ "a" "\\Q\\E" f matches? ] unit-test +[ t ] [ "|*+" "\\Q|*+\\E" f matches? ] unit-test +[ f ] [ "abc" "\\Q|*+\\E" f 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 matches? ] unit-test +[ t ] [ "SXY" "\\0123XY" f matches? ] unit-test +[ t ] [ "x" "\\x78" f matches? ] unit-test +[ f ] [ "y" "\\x78" f matches? ] unit-test +[ t ] [ "x" "\\u0078" f matches? ] unit-test +[ f ] [ "y" "\\u0078" f 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 matches? ] unit-test +[ f ] [ "b" "a+b" f matches? ] unit-test +[ t ] [ "aab" "a+b" f matches? ] unit-test +[ f ] [ "abb" "a+b" f 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 matches? ] unit-test +[ t ] [ "a" "ab*" f matches? ] unit-test +[ f ] [ "abab" "ab*" f matches? ] unit-test -[ f ] [ "x" "\\." matches? ] unit-test -[ t ] [ "." "\\." matches? ] unit-test +[ f ] [ "x" "\\." f matches? ] unit-test +[ t ] [ "." "\\." f matches? ] unit-test + +[ t ] [ "aaaab" "a+ab" f matches? ] unit-test +[ f ] [ "aaaxb" "a+ab" f matches? ] unit-test +[ t ] [ "aaacb" "a+cb" f matches? ] unit-test +[ f ] [ "aaaab" "a++ab" f matches? ] unit-test +[ t ] [ "aaacb" "a++cb" f matches? ] unit-test + +[ 3 ] [ "aaacb" "a*" f match-head ] unit-test +[ 1 ] [ "aaacb" "a+?" f match-head ] unit-test +[ 2 ] [ "aaacb" "aa?" f match-head ] unit-test +[ 1 ] [ "aaacb" "aa??" f match-head ] unit-test +[ 3 ] [ "aacb" "aa?c" f match-head ] unit-test +[ 3 ] [ "aacb" "aa??c" f match-head ] unit-test + +[ t ] [ "aaa" "AAA" t matches? ] unit-test +[ f ] [ "aax" "AAA" t matches? ] unit-test +[ t ] [ "aaa" "A*" t matches? ] unit-test +[ f ] [ "aaba" "A*" t matches? ] unit-test +[ t ] [ "b" "[AB]" t matches? ] unit-test +[ f ] [ "c" "[AB]" t matches? ] unit-test +[ t ] [ "c" "[A-Z]" t matches? ] unit-test +[ f ] [ "3" "[A-Z]" t 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 drop +] unit-test diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor index 55d15aed42..9d696319fc 100755 --- a/extra/regexp/regexp.factor +++ b/extra/regexp/regexp.factor @@ -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 +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 ; + [ >r token r> <@literal ] { } assoc>map ; : '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 -: 'grouping' +: 'non-capturing-group' ( -- parser ) + 'regexp' "(?:" ")" surrounded-by ; + +: 'group' ( -- parser ) 'regexp' [ [ ] <@ ] <@ "(" ")" 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 "[" "]" surrounded-by [ satisfy ] <@ ; : 'escaped-seq' ( -- parser ) - any-char-parser <*> [ token ] <@ "\\Q" "\\E" surrounded-by ; + any-char-parser <*> + [ ignore-case? get ] <@ + "\\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' <|> <|> - <+> [ ] <@ ; + 'simple' + 'repetition' 'interval' 'dummy' <|> <|> <&> [ first2 call ] <@ + [ ] <@ ; LAZY: 'regexp' ( -- parser ) - 'term' "|" token nonempty-list-of [ ] <@ - "^" token 'term' "|" token nonempty-list-of [ ] <@ - &> [ "caret" print ] <@ <|> - 'term' "|" token nonempty-list-of [ ] <@ - "$" token <& [ "dollar" print ] <@ <|> - "^" token 'term' "|" token nonempty-list-of [ ] <@ &> - "$" token [ "caret dollar" print ] <@ <& <|> ; + 'term' "|" token nonempty-list-of [ ] <@ ; +! "^" token 'term' "|" token nonempty-list-of [ ] <@ +! &> [ "caret" print ] <@ <|> +! 'term' "|" token nonempty-list-of [ ] <@ +! "$" token <& [ "dollar" print ] <@ <|> +! "^" token 'term' "|" token nonempty-list-of [ ] <@ &> +! "$" token [ "caret dollar" print ] <@ <& <|> ; -TUPLE: regexp source parser ; +TUPLE: regexp source parser ignore-case? ; -: dup 'regexp' just parse-1 regexp construct-boa ; +: ( string ignore-case? -- regexp ) + [ + ignore-case? [ + dup 'regexp' just parse-1 + ] with-variable + ] keep regexp construct-boa ; -GENERIC: >regexp ( obj -- parser ) - -M: string >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 parsed ; + ] change-column + lexer get (parse-token) parse-options 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 ; diff --git a/extra/rss/rss.factor b/extra/rss/rss.factor index f9d7067e58..cfb1c903e8 100644 --- a/extra/rss/rss.factor +++ b/extra/rss/rss.factor @@ -88,12 +88,15 @@ C: 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 ) diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index 43b30d7a9f..0146deed98 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -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 -- ) diff --git a/extra/webapps/article-manager/article-manager.factor b/extra/webapps/article-manager/article-manager.factor index cb999818d2..66e7faff94 100644 --- a/extra/webapps/article-manager/article-manager.factor +++ b/extra/webapps/article-manager/article-manager.factor @@ -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 [ write f rot render-component ] curry html-document + ] serve-html ; + TUPLE: template-args arg1 ; C: template-args diff --git a/extra/webapps/article-manager/furnace/article.furnace b/extra/webapps/article-manager/furnace/article.furnace index f0647aa442..c3a19263be 100644 --- a/extra/webapps/article-manager/furnace/article.furnace +++ b/extra/webapps/article-manager/furnace/article.furnace @@ -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 ; %> - <% f "navigation" render-template %> + <% "navigation" render-template %>
<% 100 random 25 > [ "arg1" get first 100 random 50 > [ site-ad2 ] [ site-ad3 ] if write-html ] when %> <% "arg1" get second article-body write-html %>

Tags

- <% "arg1" get second tags-for-article "tags" render-template %> + <% "arg1" get second tags-for-article "tags" render-component %>
diff --git a/extra/webapps/article-manager/furnace/index.furnace b/extra/webapps/article-manager/furnace/index.furnace index ae8963c3b0..da48d324cc 100644 --- a/extra/webapps/article-manager/furnace/index.furnace +++ b/extra/webapps/article-manager/furnace/index.furnace @@ -6,7 +6,7 @@ - <% f "navigation" render-template %> + <% "navigation" render-template %>
<% "intro" get write-html %>

Recent Articles

@@ -23,7 +23,7 @@ but in the meantime, Google is likely to provide reasonable results.

- <% host all-tags "tags" render-template %> + <% host all-tags "tags" render-component %>
diff --git a/extra/webapps/article-manager/furnace/navigation.furnace b/extra/webapps/article-manager/furnace/navigation.furnace index 33fb29914e..b42a384ca1 100644 --- a/extra/webapps/article-manager/furnace/navigation.furnace +++ b/extra/webapps/article-manager/furnace/navigation.furnace @@ -5,5 +5,5 @@ <% current-site site-ad1 write-html %>

Tags

- <% host all-tags "tags" render-template %> + <% host all-tags "tags" render-component %> diff --git a/extra/webapps/article-manager/furnace/tag.furnace b/extra/webapps/article-manager/furnace/tag.furnace index a778deb9be..4e04196097 100644 --- a/extra/webapps/article-manager/furnace/tag.furnace +++ b/extra/webapps/article-manager/furnace/tag.furnace @@ -1,7 +1,7 @@ <% USING: kernel io http.server namespaces sequences math html furnace webapps.article-manager.database webapps.article-manager html.elements ; %> - <% f "navigation" render-template %> + <% "navigation" render-component %>

<% "arg1" get second tag-title write %>

<% "arg1" get second tag-description write-html %> diff --git a/extra/webapps/file/file.factor b/extra/webapps/file/file.factor old mode 100644 new mode 100755 index d8fec990db..3a8feddbad --- a/extra/webapps/file/file.factor +++ b/extra/webapps/file/file.factor @@ -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 ] [ - stdio get stream-copy + >r dup 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 diff --git a/extra/webapps/fjsc/fjsc.factor b/extra/webapps/fjsc/fjsc.factor index bede8846c1..b21e91bc8f 100755 --- a/extra/webapps/fjsc/fjsc.factor +++ b/extra/webapps/fjsc/fjsc.factor @@ -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* ; diff --git a/extra/webapps/help/help.factor b/extra/webapps/help/help.factor index 8456e499f1..145df4119a 100644 --- a/extra/webapps/help/help.factor +++ b/extra/webapps/help/help.factor @@ -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 ; diff --git a/extra/webapps/pastebin/annotate-paste.furnace b/extra/webapps/pastebin/annotate-paste.furnace old mode 100644 new mode 100755 index c963e2f88f..abb5cc3d07 --- a/extra/webapps/pastebin/annotate-paste.furnace +++ b/extra/webapps/pastebin/annotate-paste.furnace @@ -1,4 +1,4 @@ -<% USING: io math math.parser namespaces ; %> +<% USING: io math math.parser namespaces furnace ; %>

Annotate

@@ -9,17 +9,22 @@ string write %>" /> -Your name: - - - - -Summary: +Summary: -Contents: +Your name: + + + + +File type: +<% "modes" render-template %> + + + +Content: diff --git a/extra/webapps/pastebin/annotation.furnace b/extra/webapps/pastebin/annotation.furnace old mode 100644 new mode 100755 index ed1bdac845..791905197e --- a/extra/webapps/pastebin/annotation.furnace +++ b/extra/webapps/pastebin/annotation.furnace @@ -1,11 +1,11 @@ -<% USING: namespaces io ; %> +<% USING: namespaces io furnace calendar ; %>

Annotation: <% "summary" get write %>

- +
Annotation by:<% "author" get write %>
Channel:<% "channel" get write %>
Created:<% "date" get write %>
Created:<% "date" get timestamp>string write %>
-
<% "contents" get write %>
+<% "syntax" render-template %> diff --git a/extra/webapps/pastebin/footer.furnace b/extra/webapps/pastebin/footer.furnace new file mode 100644 index 0000000000..15b90110a0 --- /dev/null +++ b/extra/webapps/pastebin/footer.furnace @@ -0,0 +1,3 @@ + + + diff --git a/extra/webapps/pastebin/header.furnace b/extra/webapps/pastebin/header.furnace new file mode 100644 index 0000000000..2c8e79a18d --- /dev/null +++ b/extra/webapps/pastebin/header.furnace @@ -0,0 +1,23 @@ +<% USING: namespaces io furnace sequences xmode.code2html webapps.pastebin ; %> + + + + + + + + <% "title" get write %> + + <% default-stylesheet %> + + + + + + +

<% "title" get write %>

diff --git a/extra/webapps/pastebin/modes.furnace b/extra/webapps/pastebin/modes.furnace new file mode 100644 index 0000000000..960b7d4e27 --- /dev/null +++ b/extra/webapps/pastebin/modes.furnace @@ -0,0 +1,7 @@ +<% USING: xmode.catalog sequences kernel html.elements assocs io sorting ; %> + + diff --git a/extra/webapps/pastebin/new-paste.furnace b/extra/webapps/pastebin/new-paste.furnace old mode 100644 new mode 100755 index 8a2544e801..46cf0df818 --- a/extra/webapps/pastebin/new-paste.furnace +++ b/extra/webapps/pastebin/new-paste.furnace @@ -1,27 +1,41 @@ +<% USING: furnace namespaces ; %> + +<% + "New paste" "title" set + "header" render-template +%> +
- - - - - - + - + + + + + + + + + + + - +
Your name:
Summary:Summary:
Channel:Your name:
File type:<% "modes" render-template %>
Channel:
Contents:Content:
+ +<% "footer" render-template %> diff --git a/extra/webapps/pastebin/paste-list.furnace b/extra/webapps/pastebin/paste-list.furnace index 7a25ae2f50..da2d1add9c 100644 --- a/extra/webapps/pastebin/paste-list.furnace +++ b/extra/webapps/pastebin/paste-list.furnace @@ -1,7 +1,31 @@ <% USING: namespaces furnace sequences ; %> - -<% "new-paste-quot" get "New paste" render-link %> - -<% "pastes" get [ "paste-summary" render-template ] each %>
 Summary:Paste by:LinkDate
+<% + "Pastebin" "title" set + "header" render-template +%> + + + + + +
+ + + + + + + <% "pastes" get [ "paste-summary" render-component ] each %> +
Summary:Paste by:Date:
+
+

This pastebin is written in Factor. It is inspired by lisppaste. +

+

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

+

+ <% "webapps.pastebin" browse-webapp-source %>

+
+ +<% "footer" render-template %> diff --git a/extra/webapps/pastebin/paste-summary.furnace b/extra/webapps/pastebin/paste-summary.furnace index f5c156a27e..2840110549 100644 --- a/extra/webapps/pastebin/paste-summary.furnace +++ b/extra/webapps/pastebin/paste-summary.furnace @@ -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 ; %> -<% "n" get number>string write %> -<% "summary" get write %> -<% "author" get write %> -<% "n" get number>string "show-paste-quot" get curry "Show" render-link %> -<% "date" get print %> + + + <% + "summary" get + dup empty? [ drop "- no title -" ] when + write + %> + + + <% "author" get write %> + <% "date" get timestamp>string print %> diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor old mode 100644 new mode 100755 index f592f96448..48154fef85 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -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 ) 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 ; -: ( summary author channel contents -- paste ) - V{ } clone - { - set-paste-summary - set-paste-author - set-paste-channel - set-paste-contents - set-paste-annotations - } paste construct ; +: ( 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 - 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 + ] map ; + +: feed.xml ( -- ) + "text/xml" serving-content + "pastebin" + "http://pastebin.factorcode.org" + paste-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 -- ) - - \ pastebin get-global add-paste - save-pastebin-store ; +: submit-paste ( summary author channel mode contents -- ) + [ + \ 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 -- ) 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 diff --git a/extra/webapps/pastebin/show-paste.furnace b/extra/webapps/pastebin/show-paste.furnace old mode 100644 new mode 100755 index b3b4e99b6e..6a78135343 --- a/extra/webapps/pastebin/show-paste.furnace +++ b/extra/webapps/pastebin/show-paste.furnace @@ -1,15 +1,21 @@ -<% USING: namespaces io furnace sequences ; %> +<% USING: namespaces io furnace sequences xmode.code2html calendar ; %> -

Paste: <% "summary" get write %>

+<% + "Paste: " "summary" get append "title" set + "header" render-template +%> - + +
Paste by:<% "author" get write %>
Channel:<% "channel" get write %>
Created:<% "date" get write %>
Created:<% "date" get timestamp>string write %>
File type:<% "mode" get write %>
-
<% "contents" get write %>
+<% "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 %> diff --git a/extra/webapps/pastebin/style.css b/extra/webapps/pastebin/style.css new file mode 100644 index 0000000000..e3c7c19fc5 --- /dev/null +++ b/extra/webapps/pastebin/style.css @@ -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; +} diff --git a/extra/webapps/pastebin/syntax.furnace b/extra/webapps/pastebin/syntax.furnace new file mode 100755 index 0000000000..17b64b920b --- /dev/null +++ b/extra/webapps/pastebin/syntax.furnace @@ -0,0 +1,3 @@ +<% USING: xmode.code2html splitting namespaces ; %> + +
<% "contents" get string-lines "mode" get htmlize-lines %>
diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index 9fdafe033b..75440816be 100644 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -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 ; - -: ( 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 -- )

- dup posting-title write
- "- " write - dup posting-author write bl - + dup entry-title write
+
"Read More..." write

; @@ -51,70 +24,86 @@ TUPLE: posting author title date link body ; ; : format-date ( date -- string ) - 10 head "-" split [ string>number ] map - first3 0 0 0 0 - [ - dup timestamp-day # - " " % - dup timestamp-month month-abbreviations nth % - ", " % - timestamp-year # - ] "" make ; + rfc3339>timestamp timestamp>string ; : print-posting ( posting -- )

- - dup posting-title write-html - " - " write - dup posting-author write + + dup entry-title write-html

-

dup posting-body write-html

-

posting-date format-date write

; +

+ dup entry-description write-html +

+

+ entry-pub-date format-date write +

; : print-postings ( postings -- ) [ print-posting ] each ; -: browse-webapp-source ( vocab -- ) - vocab-link browser-link-href =href a> - "Browse source" write - ; - SYMBOL: default-blogroll SYMBOL: cached-postings -: update-cached-postings ( -- ) - default-blogroll get fetch-blogroll sort-entries - [ ] 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.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 ; + +: ( 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 + swap [ ?fetch-feed ] parallel-map + [ [ ] curry* map ] 2map concat ; + +: sort-entries ( entries -- entries' ) + [ [ entry-pub-date ] compare ] sort ; + +: 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> - 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 diff --git a/extra/webapps/planet/planet.fhtml b/extra/webapps/planet/planet.furnace similarity index 69% rename from extra/webapps/planet/planet.fhtml rename to extra/webapps/planet/planet.furnace index fb5a673077..4c6676c0a2 100644 --- a/extra/webapps/planet/planet.fhtml +++ b/extra/webapps/planet/planet.furnace @@ -1,4 +1,5 @@ -<% USING: namespaces html.elements webapps.planet sequences ; %> +<% USING: namespaces html.elements webapps.planet sequences +furnace ; %> @@ -8,14 +9,15 @@ planet-factor - + +

[ planet-factor ]

- +
<% cached-postings get 20 head print-postings %> <% cached-postings get 20 safe-head print-postings %>

planet-factor is an Atom/RSS aggregator that collects the @@ -23,7 +25,11 @@ Planet Lisp.

- This webapp is written in Factor. + + Syndicate +

+

+ This webapp is written in Factor.
<% "webapps.planet" browse-webapp-source %>

Blogroll

diff --git a/extra/webapps/planet/style.css b/extra/webapps/planet/style.css new file mode 100644 index 0000000000..7a66d8d495 --- /dev/null +++ b/extra/webapps/planet/style.css @@ -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; +} diff --git a/extra/webapps/source/source.factor b/extra/webapps/source/source.factor new file mode 100755 index 0000000000..efc46c68b7 --- /dev/null +++ b/extra/webapps/source/source.factor @@ -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 diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor index bb8919dd70..5e0f4ddc65 100755 --- a/extra/windows/kernel32/kernel32.factor +++ b/extra/windows/kernel32/kernel32.factor @@ -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 diff --git a/extra/windows/nt/nt.factor b/extra/windows/nt/nt.factor index d9e8f58cc2..8a709416d8 100644 --- a/extra/windows/nt/nt.factor +++ b/extra/windows/nt/nt.factor @@ -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" } diff --git a/extra/windows/shell32/shell32.factor b/extra/windows/shell32/shell32.factor new file mode 100644 index 0000000000..501f49edfe --- /dev/null +++ b/extra/windows/shell32/shell32.factor @@ -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" + [ 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 ; diff --git a/extra/windows/windows.factor b/extra/windows/windows.factor index 657a8e8a7c..e07c504781 100755 --- a/extra/windows/windows.factor +++ b/extra/windows/windows.factor @@ -7,6 +7,7 @@ IN: windows : lo-word ( wparam -- lo ) *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 ) ; diff --git a/extra/xml/data/data.factor b/extra/xml/data/data.factor index 1850171537..58ff2a3f6c 100644 --- a/extra/xml/data/data.factor +++ b/extra/xml/data/data.factor @@ -65,7 +65,6 @@ M: attrs set-at M: attrs assoc-size length ; M: attrs new-assoc drop V{ } new ; -M: attrs assoc-find >r delegate r> assoc-find ; M: attrs >alist delegate >alist ; : >attrs ( assoc -- attrs ) diff --git a/extra/xmode/README.txt b/extra/xmode/README.txt index bf73042030..57d9f42b22 100755 --- a/extra/xmode/README.txt +++ b/extra/xmode/README.txt @@ -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. diff --git a/extra/xmode/catalog/catalog-tests.factor b/extra/xmode/catalog/catalog-tests.factor index e5d049de72..d5420ed2e3 100644 --- a/extra/xmode/catalog/catalog-tests.factor +++ b/extra/xmode/catalog/catalog-tests.factor @@ -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 diff --git a/extra/xmode/catalog/catalog.factor b/extra/xmode/catalog/catalog.factor index cde9c6b025..866bd69106 100644 --- a/extra/xmode/catalog/catalog.factor +++ b/extra/xmode/catalog/catalog.factor @@ -26,7 +26,7 @@ TAGS> "extra/xmode/modes/catalog" resource-path read-xml parse-modes-tag ; -: modes ( -- ) +: modes ( -- assoc ) \ modes get-global [ load-catalog dup \ modes set-global ] unless* ; diff --git a/extra/xmode/code2html/code2html.factor b/extra/xmode/code2html/code2html.factor old mode 100644 new mode 100755 index 02bf74dc23..dfc50988a3 --- a/extra/xmode/code2html/code2html.factor +++ b/extra/xmode/code2html/code2html.factor @@ -15,8 +15,8 @@ IN: xmode.code2html : htmlize-line ( line-context line rules -- line-context' ) tokenize-line htmlize-tokens ; -: htmlize-lines ( lines rules -- ) -
 f -rot [ htmlize-line nl ] curry each drop 
; +: htmlize-lines ( lines mode -- ) + f swap load-mode [ htmlize-line nl ] curry reduce drop ; : default-stylesheet ( -- ) ; +: htmlize-stream ( path stream -- ) + lines swap + + + default-stylesheet + dup write + + +
+                over empty?
+                [ 2drop ]
+                [ over first find-mode htmlize-lines ] if
+            
+ + ; + : htmlize-file ( path -- ) - dup lines dup empty? [ 2drop ] [ - swap dup ".html" append [ - [ - - - dup write - default-stylesheet - - - over first - find-mode - load-mode - htmlize-lines - - - ] with-html-stream - ] with-stream - ] if ; + dup over ".html" append + [ htmlize-stream ] with-stream ; diff --git a/extra/xmode/keyword-map/keyword-map.factor b/extra/xmode/keyword-map/keyword-map.factor index b75c24393c..350d8572a0 100644 --- a/extra/xmode/keyword-map/keyword-map.factor +++ b/extra/xmode/keyword-map/keyword-map.factor @@ -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) diff --git a/extra/xmode/loader/loader.factor b/extra/xmode/loader/loader.factor index c6b5cad9d1..ac1d1d66ca 100755 --- a/extra/xmode/loader/loader.factor +++ b/extra/xmode/loader/loader.factor @@ -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 ; + dup children>string + ignore-case? get + swap position-attrs ; : parse-regexp-matcher ( tag -- matcher ) - dup children>string swap position-attrs ; + dup children>string ignore-case? get + swap position-attrs ; ! SPAN's children 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 + swap child-tags [ over parse-keyword-tag ] each + swap set-rule-set-keywords ; TAGS> +: ? dup [ ignore-case? get ] when ; + : (parse-rules-tag) ( tag -- 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" set-rule-set-digit-re } ! XXX + { "DIGIT_RE" ? 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 -- ) diff --git a/extra/xmode/marker/marker-tests.factor b/extra/xmode/marker/marker-tests.factor index cb7f2960a4..5b0aff2050 100755 --- a/extra/xmode/marker/marker-tests.factor +++ b/extra/xmode/marker/marker-tests.factor @@ -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 diff --git a/extra/xmode/marker/marker.factor b/extra/xmode/marker/marker.factor index cd9eacbb88..b22844b45b 100755 --- a/extra/xmode/marker/marker.factor +++ b/extra/xmode/marker/marker.factor @@ -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 diff --git a/extra/xmode/marker/state/state.factor b/extra/xmode/marker/state/state.factor index cce7c7567a..fc731aba34 100755 --- a/extra/xmode/marker/state/state.factor +++ b/extra/xmode/marker/state/state.factor @@ -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 diff --git a/extra/xmode/rules/rules.factor b/extra/xmode/rules/rules.factor index 7206668edb..85d50a5bbe 100755 --- a/extra/xmode/rules/rules.factor +++ b/extra/xmode/rules/rules.factor @@ -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 + ! 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 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 ; : ( -- 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 ; : ( string -- rule ) - f f f + f f f f 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 r> - 2dup set-rule-set-escape-rule - add-rule ; + over [ + >r r> + 2dup set-rule-set-escape-rule + add-rule + ] [ + 2drop + ] if ; diff --git a/misc/factor.sh b/misc/factor.sh index 616119dd61..11ea2a9cdf 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -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 diff --git a/extra/furnace/scaffold/crud-templates/edit.furnace b/unmaintained/scaffold/crud-templates/edit.furnace similarity index 100% rename from extra/furnace/scaffold/crud-templates/edit.furnace rename to unmaintained/scaffold/crud-templates/edit.furnace diff --git a/extra/furnace/scaffold/crud-templates/list.furnace b/unmaintained/scaffold/crud-templates/list.furnace similarity index 100% rename from extra/furnace/scaffold/crud-templates/list.furnace rename to unmaintained/scaffold/crud-templates/list.furnace diff --git a/extra/furnace/scaffold/crud-templates/show.furnace b/unmaintained/scaffold/crud-templates/show.furnace similarity index 100% rename from extra/furnace/scaffold/crud-templates/show.furnace rename to unmaintained/scaffold/crud-templates/show.furnace diff --git a/extra/furnace/scaffold/scaffold.factor b/unmaintained/scaffold/scaffold.factor similarity index 97% rename from extra/furnace/scaffold/scaffold.factor rename to unmaintained/scaffold/scaffold.factor index f0c2850ab5..e74374c245 100644 --- a/extra/furnace/scaffold/scaffold.factor +++ b/unmaintained/scaffold/scaffold.factor @@ -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 @@ -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 ; diff --git a/vm/os-linux-x86-64.h b/vm/os-linux-x86-64.h index 2bbae86f6e..911c2f1749 100644 --- a/vm/os-linux-x86-64.h +++ b/vm/os-linux-x86-64.h @@ -1,2 +1,10 @@ +#include + +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]) diff --git a/vm/os-windows-nt.c b/vm/os-windows-nt.c index be9dde1fa8..da54b794d1 100755 --- a/vm/os-windows-nt.c +++ b/vm/os-windows-nt.c @@ -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); diff --git a/vm/platform.h b/vm/platform.h index f181c93e2c..75228726a9 100644 --- a/vm/platform.h +++ b/vm/platform.h @@ -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"