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

Merge git://spitspat.com/git/factor

release
Doug Coleman 2007-12-09 18:28:10 -06:00
parent 9c79dc1fa7 4cde2561e2
commit 7559286288
101 changed files with 1749 additions and 836 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
core/combinators/combinators.factor
View File

@ -79,6 +79,10 @@ M: sequence hashcode*
dup empty? [
drop
] [
hash-case-table hash-dispatch-quot
[ dup hashcode >fixnum ] swap append
dup length 4 <= [
case>quot
] [
hash-case-table hash-dispatch-quot
[ dup hashcode >fixnum ] swap append
] if
] if ;

7
core/compiler/compiler.factor
View File

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

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

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

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

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

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

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

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

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

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

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

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

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

27
extra/calendar/calendar.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables io io.streams.string kernel math
math.vectors math.functions math.parser
namespaces sequences strings tuples system ;
math.vectors math.functions math.parser namespaces sequences
strings tuples system debugger ;
IN: calendar
TUPLE: timestamp year month day hour minute second gmt-offset ;
@ -316,7 +316,28 @@ M: timestamp <=> ( ts1 ts2 -- n )
: timestamp>rfc3339 ( timestamp -- str )
>gmt [
(timestamp>rfc3339)
] string-out ;
] string-out ;
: expect read1 assert= ;
: (rfc3339>timestamp) ( -- timestamp )
4 read string>number ! year
CHAR: - expect
2 read string>number ! month
CHAR: - expect
2 read string>number ! day
CHAR: T expect
2 read string>number ! hour
CHAR: : expect
2 read string>number ! minute
CHAR: : expect
2 read string>number ! second
0 <timestamp> ;
: rfc3339>timestamp ( str -- timestamp )
[
(rfc3339>timestamp)
] string-in ;
: file-time-string ( timestamp -- string )
[

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

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

4
extra/delegate/delegate.factor
View File

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -0,0 +1 @@
Doug Coleman

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

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

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

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

57
extra/furnace/furnace.factor
View File

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

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

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

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

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

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

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

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

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

2
extra/http/http.factor
View File

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

16
extra/id3/id3.factor
View File

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

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

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

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

@ -7,7 +7,8 @@ IN: windows.ce.files
! M: windows-ce-io normalize-pathname ( string -- string )
! 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 -- )

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

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

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

@ -62,7 +62,7 @@ M: windows-ce-io with-privileges
: mmap-open ( path access-mode create-mode flProtect access -- handle handle address )
{ "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

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

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

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

@ -3,8 +3,8 @@ io.windows.nt io.windows.nt.backend kernel libc math
threads windows windows.kernel32 ;
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 ;

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

@ -4,7 +4,7 @@ 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 ;
@ -23,7 +23,7 @@ TUPLE: win32-file handle ptr overlapped ;
: <win32-duplex-stream> ( in out -- stream )
>r f <win32-file> r> f <win32-file> handle>duplex-stream ;
HOOK: CreateFile-flags io-backend ( -- DWORD )
HOOK: CreateFile-flags io-backend ( DWORD -- DWORD )
HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
HOOK: add-completion io-backend ( port -- )
@ -31,7 +31,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 +41,25 @@ M: win32-file close-handle ( handle -- )
win32-file-handle CloseHandle drop ;
! Clean up resources (open handle) if add-completion fails
: open-file ( path access-mode create-mode -- handle )
: open-file ( path access-mode create-mode flags -- handle )
[
>r share-mode f r> CreateFile-flags f CreateFile
>r >r >r normalize-pathname r>
share-mode f r> r> CreateFile-flags f CreateFile
dup invalid-handle? dup close-later
dup add-completion
] with-destructors ;
: open-pipe-r/w ( path -- handle )
GENERIC_READ GENERIC_WRITE bitor OPEN_EXISTING open-file ;
GENERIC_READ GENERIC_WRITE bitor OPEN_EXISTING 0 open-file ;
: open-read ( path -- handle length )
normalize-pathname GENERIC_READ OPEN_EXISTING open-file 0 ;
GENERIC_READ OPEN_EXISTING 0 open-file 0 ;
: open-write ( path -- handle length )
normalize-pathname GENERIC_WRITE CREATE_ALWAYS open-file 0 ;
GENERIC_WRITE CREATE_ALWAYS 0 open-file 0 ;
: (open-append) ( path -- handle )
normalize-pathname GENERIC_WRITE OPEN_ALWAYS open-file ;
GENERIC_WRITE OPEN_ALWAYS 0 open-file ;
: set-file-pointer ( handle length -- )
dupd d>w/w <uint> FILE_BEGIN SetFilePointer

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

@ -32,7 +32,7 @@ M: nehe4-gadget draw-gadget* ( gadget -- )
glLoadIdentity
-1.5 0.0 -6.0 glTranslatef
dup nehe4-gadget-rtri 0.0 1.0 0.0 glRotatef
GL_TRIANGLES [
1.0 0.0 0.0 glColor3f
0.0 1.0 0.0 glVertex3f
@ -52,23 +52,23 @@ M: nehe4-gadget draw-gadget* ( gadget -- )
1.0 1.0 0.0 glVertex3f
1.0 -1.0 0.0 glVertex3f
-1.0 -1.0 0.0 glVertex3f
] do-state
] do-state
dup nehe4-gadget-rtri 0.2 + over set-nehe4-gadget-rtri
dup nehe4-gadget-rquad 0.15 - swap set-nehe4-gadget-rquad ;
: nehe4-update-thread ( gadget -- )
dup nehe4-gadget-quit? [
redraw-interval sleep
dup relayout-1
nehe4-update-thread
] unless ;
: nehe4-update-thread ( gadget -- )
dup nehe4-gadget-quit? [ drop ] [
redraw-interval sleep
dup relayout-1
nehe4-update-thread
] if ;
M: nehe4-gadget graft* ( gadget -- )
[ f swap set-nehe4-gadget-quit? ] keep
[ nehe4-update-thread ] in-thread drop ;
[ f swap set-nehe4-gadget-quit? ] keep
[ nehe4-update-thread ] in-thread drop ;
M: nehe4-gadget ungraft* ( gadget -- )
t swap set-nehe4-gadget-quit? ;
t swap set-nehe4-gadget-quit? ;
: run4 ( -- )
<nehe4-gadget> "NeHe Tutorial 4" open-window ;

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

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

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

@ -0,0 +1 @@
Gavin Harrison

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

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

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

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

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

@ -0,0 +1 @@
prolog

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

@ -1,22 +1,12 @@
USING: kernel math sequences namespaces errors hashtables words
arrays parser compiler syntax io tools prettyprint optimizer
inference ;
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
: max-length 15 ; inline
: max-value 1000000000 ; inline
: 10% ( -- bool ) 10 random 8 > ;
: 20% ( -- bool ) 10 random 7 > ;
: 30% ( -- bool ) 10 random 6 > ;
: 40% ( -- bool ) 10 random 5 > ;
: 50% ( -- bool ) 10 random 4 > ;
: 60% ( -- bool ) 10 random 3 > ;
: 70% ( -- bool ) 10 random 2 > ;
: 80% ( -- bool ) 10 random 1 > ;
: 90% ( -- bool ) 10 random 0 > ;
! varying bit-length random number
: random-bits ( n -- int )
random 2 swap ^ random ;
@ -31,32 +21,29 @@ IN: random-tester
SYMBOL: special-integers
[ { -1 0 1 } % most-negative-fixnum , most-positive-fixnum , first-bignum , ]
{ } make \ special-integers set-global
: special-integers ( -- seq ) \ special-integers get ;
SYMBOL: special-floats
[ { 0.0 -0.0 } % e , pi , 1./0. , -1./0. , 0./0. , epsilon , epsilon neg , ]
{ } make \ special-floats set-global
: special-floats ( -- seq ) \ special-floats get ;
SYMBOL: special-complexes
[
{ -1 0 1 i -i } %
{ -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> ,
e neg e neg rect> , e e rect> ,
] { } make \ special-complexes set-global
: special-complexes ( -- seq ) \ special-complexes get ;
: 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 )
@ -67,12 +54,12 @@ SYMBOL: special-complexes
] 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 )

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

@ -1,5 +1,5 @@
USING: arrays assocs combinators.lib continuations kernel
math math.functions namespaces quotations random sequences
math math.functions memoize namespaces quotations random sequences
sequences.private shuffle ;
IN: random-tester.utils
@ -93,3 +93,14 @@ C: <p-list> p-list
>r make-p-list r> (each-permutation) ;
: builder-permutations ( n -- seq )
{ [ compose ] [ swap curry ] } swap permutations
[ concat ] map ; foldable
: all-quot-permutations ( seq -- newseq )
dup length 1- builder-permutations
swap [ 1quotation ] map dup length permutations
[ swap [ >r seq>stack r> call ] curry* map ] curry* map ;
! clear { map sq 10 } all-quot-permutations [ [ [ [ [ call ] keep datastack length 2 = [ . .s nl ] when ] catch ] in-thread drop ] each ] each
! clear { map sq sq 10 } all-quot-permutations [ [ [ [ [ call ] keep datastack length 2 = [ . .s nl ] when ] catch ] in-thread drop ] each ] each

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

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

168
extra/regexp/regexp.factor
View File

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

73
extra/rss/rss.factor
View File

@ -9,6 +9,9 @@ USING: xml.utilities kernel assocs
: ?children>string ( tag/f -- string/f )
[ children>string ] [ f ] if* ;
: any-tag-named ( tag names -- tag-inside )
f -rot [ tag-named nip dup ] curry* find 2drop ;
TUPLE: feed title link entries ;
C: <feed> feed
@ -17,50 +20,51 @@ TUPLE: entry title link description pub-date ;
C: <entry> entry
: rss1.0-entry ( tag -- entry )
[ "title" tag-named children>string ] keep
[ "link" tag-named children>string ] keep
[ "description" tag-named children>string ] keep
f "date" "http://purl.org/dc/elements/1.1/" <name>
tag-named ?children>string
<entry> ;
: rss1.0 ( xml -- feed )
[
"channel" tag-named
[ "title" tag-named children>string ] keep
"link" tag-named children>string
] keep
"item" tags-named [
[ "title" tag-named children>string ] keep
[ "link" tag-named children>string ] keep
[ "description" tag-named children>string ] keep
f "date" "http://purl.org/dc/elements/1.1/" <name>
tag-named ?children>string
<entry>
] map <feed> ;
"item" tags-named [ rss1.0-entry ] map <feed> ;
: rss2.0-entry ( tag -- entry )
[ "title" tag-named children>string ] keep
[ "link" tag-named ] keep
[ "guid" tag-named dupd ? children>string ] keep
[ "description" tag-named children>string ] keep
"pubDate" tag-named children>string <entry> ;
: rss2.0 ( xml -- feed )
"channel" tag-named
[ "title" tag-named children>string ] keep
[ "link" tag-named children>string ] keep
"item" tags-named [
[ "title" tag-named children>string ] keep
[ "link" tag-named ] keep
[ "guid" tag-named dupd ? children>string ] keep
[ "description" tag-named children>string ] keep
"pubDate" tag-named children>string <entry>
] map <feed> ;
"item" tags-named [ rss2.0-entry ] map <feed> ;
: atom1.0-entry ( tag -- entry )
[ "title" tag-named children>string ] keep
[ "link" tag-named "href" swap at ] keep
[
{ "content" "summary" } any-tag-named
dup tag-children [ string? not ] contains?
[ tag-children [ write-chunk ] string-out ]
[ children>string ] if
] keep
{ "published" "updated" "issued" "modified" } any-tag-named
children>string <entry> ;
: atom1.0 ( xml -- feed )
[ "title" tag-named children>string ] keep
[ "link" tag-named "href" swap at ] keep
"entry" tags-named [
[ "title" tag-named children>string ] keep
[ "link" tag-named "href" swap at ] keep
[
dup "content" tag-named
[ nip ] [ "summary" tag-named ] if*
dup tag-children [ tag? ] contains?
[ tag-children [ write-chunk ] string-out ]
[ children>string ] if
] keep
dup "published" tag-named
[ nip ] [ "updated" tag-named ] if*
children>string <entry>
] map <feed> ;
"entry" tags-named [ atom1.0-entry ] map <feed> ;
: xml>feed ( xml -- feed )
dup name-tag {
@ -74,7 +78,7 @@ C: <entry> entry
: download-feed ( url -- feed )
#! Retrieve an news syndication file, return as a feed tuple.
http-get rot 200 = [
http-get-stream rot 200 = [
nip read-feed
] [
2drop "Error retrieving newsfeed file" throw
@ -84,12 +88,15 @@ C: <entry> entry
: simple-tag, ( content name -- )
[ , ] tag, ;
: simple-tag*, ( content name attrs -- )
[ , ] tag*, ;
: entry, ( entry -- )
"entry" [
dup entry-title "title" simple-tag,
dup entry-title "title" { { "type" "html" } } simple-tag*,
"link" over entry-link "href" associate contained*,
dup entry-pub-date "published" simple-tag,
entry-description "content" simple-tag,
entry-description [ "content" { { "type" "html" } } simple-tag*, ] when*
] tag, ;
: feed>xml ( feed -- xml )
@ -99,5 +106,5 @@ C: <entry> entry
feed-entries [ entry, ] each
] make-xml* ;
: write-feed ( feed -- xml )
: write-feed ( feed -- )
feed>xml write-xml ;

6
extra/sequences/lib/lib-tests.factor
View File

@ -1,5 +1,5 @@
USING: arrays kernel sequences sequences.lib math
math.functions tools.test ;
math.functions tools.test strings ;
[ 4 ] [ { 1 2 } [ sq ] [ * ] map-reduce ] unit-test
[ 36 ] [ { 2 3 } [ sq ] [ * ] map-reduce ] unit-test
@ -42,3 +42,7 @@ math.functions tools.test ;
[ { 1 9 25 } ] [ { 1 3 5 6 } [ sq ] [ even? ] map-until ] unit-test
[ { 2 4 } ] [ { 2 4 1 3 } [ even? ] take-while ] unit-test
[ { { 0 0 } { 1 0 } { 0 1 } { 1 1 } } ] [ 2 2 exact-strings ] unit-test
[ t ] [ "ab" 4 strings [ >string ] map "abab" swap member? ] unit-test
[ { { } { 1 } { 2 } { 1 2 } } ] [ { 1 2 } power-set ] unit-test

34
extra/sequences/lib/lib.factor
View File

@ -1,5 +1,5 @@
USING: combinators.lib kernel sequences math namespaces
random sequences.private shuffle ;
USING: combinators.lib kernel sequences math namespaces assocs
random sequences.private shuffle math.functions mirrors ;
IN: sequences.lib
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -74,3 +74,33 @@ IN: sequences.lib
[ not ] compose
[ find drop [ head-slice ] when* ] curry
[ dup ] swap compose keep like ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
<PRIVATE
: translate-string ( n alphabet out-len -- seq )
[ drop /mod ] curry* map nip ;
: map-alphabet ( alphabet seq[seq] -- seq[seq] )
[ [ swap nth ] curry* map ] curry* map ;
: exact-number-strings ( n out-len -- seqs )
[ ^ ] 2keep [ translate-string ] 2curry map ;
: number-strings ( n max-length -- seqs )
1+ [ exact-number-strings ] curry* map concat ;
PRIVATE>
: exact-strings ( alphabet length -- seqs )
>r dup length r> exact-number-strings map-alphabet ;
: strings ( alphabet length -- seqs )
>r dup length r> number-strings map-alphabet ;
: nths ( nths seq -- subseq )
! nths is a sequence of ones and zeroes
>r [ length ] keep [ nth 1 = ] curry subset r>
[ nth ] curry { } map-as ;
: power-set ( seq -- subsets )
2 over length exact-number-strings swap [ nths ] curry map ;

2
extra/shuffle/shuffle.factor
View File

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

15
extra/shufflers/shufflers.factor
View File

@ -1,25 +1,14 @@
USING: kernel sequences words math math.functions arrays
shuffle quotations parser math.parser strings namespaces
splitting effects ;
splitting effects sequences.lib ;
IN: shufflers
: shuffle>string ( names shuffle -- string )
swap [ [ nth ] curry map ] curry map
first2 "-" swap 3append >string ;
: translate ( n alphabet out-len -- seq )
[ drop /mod ] curry* map nip ;
: (combinations) ( alphabet out-len -- seq[seq] )
[ ^ ] 2keep [ translate ] 2curry map ;
: combinations ( n max-out -- seq[seq] )
! This returns a seq of length O(n^m)
! where and m is max-out
1+ [ (combinations) ] curry* map concat ;
: make-shuffles ( max-out max-in -- shuffles )
[ 1+ dup rot combinations [ 2array ] curry* map ]
[ 1+ dup rot strings [ 2array ] curry* map ]
curry* map concat ;
: shuffle>quot ( shuffle -- quot )

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

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

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

@ -4,8 +4,8 @@ USING: alien alien.c-types arrays assocs ui ui.gadgets
ui.backend ui.clipboards ui.gadgets.worlds ui.gestures io kernel
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
@ -210,6 +210,9 @@ SYMBOL: hWnd
hWnd get window-focus send-gesture
drop ;
: handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
dup alpha? [ 4drop 0 ] [ DefWindowProc ] if ;
: cleanup-window ( handle -- )
dup win-title [ free ] when*
dup win-hRC wglDeleteContext win32-error=0/f
@ -257,14 +260,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 +277,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 )
@ -297,17 +298,17 @@ M: windows-ui-backend (close-window)
: handle-wm-cancelmode ( hWnd uMsg wParam lParam -- )
#! message sent if windows needs application to stop dragging
3drop drop release-capture ;
4drop release-capture ;
: handle-wm-mouseleave ( hWnd uMsg wParam lParam -- )
#! message sent if mouse leaves main application
3drop drop forget-rollover ;
4drop forget-rollover ;
! return 0 if you handle the message, else just let DefWindowProc return its val
: ui-wndproc ( -- object )
"uint" { "void*" "uint" "long" "long" } "stdcall" [
[
pick
pick ! global [ dup windows-message-name . ] bind
{
{ [ dup WM_CLOSE = ] [ drop handle-wm-close 0 ] }
{ [ dup WM_PAINT = ]
@ -322,6 +323,7 @@ M: windows-ui-backend (close-window)
{ [ dup WM_KEYUP = over WM_SYSKEYUP = or ]
[ drop 4dup handle-wm-keyup DefWindowProc ] }
{ [ dup WM_SYSCOMMAND = ] [ drop handle-wm-syscommand ] }
{ [ dup WM_SETFOCUS = ] [ drop handle-wm-set-focus 0 ] }
{ [ dup WM_KILLFOCUS = ] [ drop handle-wm-kill-focus 0 ] }
@ -434,7 +436,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 -- )

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -1,15 +1,21 @@
<% USING: namespaces io furnace sequences ; %>
<% USING: namespaces io furnace sequences xmode.code2html calendar ; %>
<h1>Paste: <% "summary" get write %></h1>
<%
"Paste: " "summary" get append "title" set
"header" render-template
%>
<table>
<tr><th>Paste by:</th><td><% "author" get write %></td></tr>
<tr><th>Channel:</th><td><% "channel" get write %></td></tr>
<tr><th>Created:</th><td><% "date" get write %></td></tr>
<tr><th>Created:</th><td><% "date" get timestamp>string write %></td></tr>
<tr><th>File type:</th><td><% "mode" get write %></td></tr>
</table>
<pre><% "contents" get write %></pre>
<% "syntax" render-template %>
<% "annotations" get [ "annotation" render-template ] each %>
<% "annotations" get [ "annotation" render-component ] each %>
<% model get "annotate-paste" render-template %>
<% model get "annotate-paste" render-component %>
<% "footer" render-template %>

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -1010,7 +1010,8 @@ FUNCTION: HANDLE GetStdHandle ( DWORD nStdHandle ) ;
! FUNCTION: GetSystemDefaultLCID
! FUNCTION: 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

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

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

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

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

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

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

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

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

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

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

1
extra/windows/windows.factor
View File

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

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

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

12
extra/xmode/README.txt
View File

@ -32,10 +32,10 @@ to depend on:
it inherits the value of the NO_WORD_SEP attribute from the previous
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.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

0
extra/rss/reader/reader.factor → unmaintained/reader/reader.factor
View File

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

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

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

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

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

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

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

59
vm/os-windows.c
View File

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

Some files were not shown because too many files have changed in this diff Show More