From 1ef0042f6a6dce2b89d30362d39796f585d06301 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Sun, 13 Apr 2008 23:52:53 -0700 Subject: [PATCH 001/145] Add a solution to project-euler.164 --- extra/project-euler/164/164.factor | 33 ++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) create mode 100644 extra/project-euler/164/164.factor diff --git a/extra/project-euler/164/164.factor b/extra/project-euler/164/164.factor new file mode 100644 index 0000000000..67397593bd --- /dev/null +++ b/extra/project-euler/164/164.factor @@ -0,0 +1,33 @@ +! Copyright (c) 2008 Eric Mertens +! See http://factorcode.org/license.txt for BSD license. +USING: arrays assocs kernel math math.ranges sequences ; + +IN: project-euler.164 + +! http://projecteuler.net/index.php?section=problems&id=164 + +! DESCRIPTION +! ----------- + +! How many 20 digit numbers n (without any leading zero) exist such +! that no three consecutive digits of n have a sum greater than 9? + +! SOLUTION +! -------- + +assoc ; + +PRIVATE> + +: euler164 ( -- n ) + init-table 19 [ next-table ] times values sum ; \ No newline at end of file From 3a9404767a484c609ae273a4a9a1344b32a12ace Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 14 Apr 2008 22:46:19 -0500 Subject: [PATCH 002/145] Minor builder changes --- extra/builder/cleanup/cleanup.factor | 2 ++ extra/builder/common/common.factor | 18 ++++-------------- extra/builder/email/email.factor | 2 ++ 3 files changed, 8 insertions(+), 14 deletions(-) diff --git a/extra/builder/cleanup/cleanup.factor b/extra/builder/cleanup/cleanup.factor index 327b90e01f..e601506fb4 100644 --- a/extra/builder/cleanup/cleanup.factor +++ b/extra/builder/cleanup/cleanup.factor @@ -8,6 +8,8 @@ IN: builder.cleanup SYMBOL: builder-debug +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + : compress-image ( -- ) { "bzip2" my-boot-image-name } to-strings try-process ; : delete-child-factor ( -- ) diff --git a/extra/builder/common/common.factor b/extra/builder/common/common.factor index e3c207eaaa..474606e451 100644 --- a/extra/builder/common/common.factor +++ b/extra/builder/common/common.factor @@ -7,6 +7,10 @@ IN: builder.common ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +SYMBOL: upload-to-factorcode + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + SYMBOL: builds-dir : builds ( -- path ) @@ -21,15 +25,6 @@ VAR: stamp : builds/factor ( -- path ) builds "factor" append-path ; : build-dir ( -- path ) builds stamp> append-path ; -: create-build-dir ( -- ) - datestamp >stamp - build-dir make-directory ; - -: enter-build-dir ( -- ) build-dir set-current-directory ; - -: clone-builds-factor ( -- ) - { "git" "clone" builds/factor } to-strings try-process ; - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : prepare-build-machine ( -- ) @@ -57,8 +52,3 @@ SYMBOL: status { status-vm status-boot status-test status-build status-release status } [ off ] each ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -SYMBOL: upload-to-factorcode - diff --git a/extra/builder/email/email.factor b/extra/builder/email/email.factor index eed48cb177..ecde47f8f7 100644 --- a/extra/builder/email/email.factor +++ b/extra/builder/email/email.factor @@ -8,6 +8,8 @@ IN: builder.email SYMBOL: builder-from SYMBOL: builder-recipients +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + : subject-status ( -- str ) status get [ "report" ] [ "error" ] if ; : subject ( -- str ) { "builder@" host-name* ": " subject-status } to-string ; From ec9954a00a97a1c673dbc9e1dd53ca21b3b65c01 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 15 Apr 2008 01:20:53 -0500 Subject: [PATCH 003/145] Add extra/update --- extra/update/update.factor | 62 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 62 insertions(+) create mode 100644 extra/update/update.factor diff --git a/extra/update/update.factor b/extra/update/update.factor new file mode 100644 index 0000000000..f186837548 --- /dev/null +++ b/extra/update/update.factor @@ -0,0 +1,62 @@ + +USING: kernel system sequences io.files io.launcher bootstrap.image + builder.util builder.release.branch ; + +IN: update + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: run-command ( cmd -- ) to-strings try-process ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: git-pull-clean ( -- ) + image parent-directory + [ + { "git" "pull" "git://factorcode.org/git/factor.git" branch-name } + run-command + ] + with-directory ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: remote-clean-image ( -- url ) + "http://factorcode.org/images/clean/" my-boot-image-name append ; + +: download-clean-image ( -- ) { "wget" remote-clean-image } run-command ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: make-clean ( -- ) { gnu-make "clean" } run-command ; +: make ( -- ) { gnu-make } run-command ; +: boot ( -- ) { "./factor" { "-i=" my-boot-image-name } } run-command ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: rebuild ( -- ) + image parent-directory + [ + download-clean-image + make-clean + make + boot + ] + with-directory ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: update ( -- ) + image parent-directory + [ + git-id + git-pull-clean + git-id + = not + [ rebuild ] + when + ] + with-directory ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +MAIN: update \ No newline at end of file From 7bcadd99a4148f52b20c6b466cc472e2b34b20fd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 15 Apr 2008 06:10:08 -0500 Subject: [PATCH 004/145] XML templating engine --- .../generate-syntax/generate-syntax.factor | 5 +- extra/http/http.factor | 15 +- extra/http/server/auth/login/boilerplate.xml | 9 + .../http/server/auth/login/edit-profile.fhtml | 77 -------- extra/http/server/auth/login/edit-profile.xml | 77 ++++++++ extra/http/server/auth/login/login.factor | 43 +++-- extra/http/server/auth/login/login.fhtml | 46 ----- extra/http/server/auth/login/login.xml | 44 +++++ extra/http/server/auth/login/recover-1.fhtml | 41 ----- extra/http/server/auth/login/recover-1.xml | 39 ++++ extra/http/server/auth/login/recover-2.fhtml | 9 - extra/http/server/auth/login/recover-2.xml | 9 + extra/http/server/auth/login/recover-3.fhtml | 46 ----- extra/http/server/auth/login/recover-3.xml | 43 +++++ extra/http/server/auth/login/recover-4.fhtml | 10 -- extra/http/server/auth/login/recover-4.xml | 9 + extra/http/server/auth/login/register.fhtml | 77 -------- extra/http/server/auth/login/register.xml | 79 ++++++++ .../server/boilerplate/boilerplate.factor | 49 +++++ .../server/components/components-tests.factor | 5 +- .../http/server/components/components.factor | 21 ++- .../server/components/farkup/farkup.factor | 5 +- extra/http/server/crud/crud.factor | 47 ++--- extra/http/server/forms/forms.factor | 32 +++- .../templating/chloe/chloe-tests.factor | 97 ++++++++++ .../http/server/templating/chloe/chloe.factor | 168 ++++++++++++++++++ .../server/templating/chloe/test/test1.xml | 5 + .../server/templating/chloe/test/test2.xml | 6 + .../templating/chloe/test/test3-aux.xml | 5 + .../server/templating/chloe/test/test3.xml | 12 ++ .../server/templating/chloe/test/test4.xml | 9 + .../server/templating/chloe/test/test5.xml | 9 + .../server/templating/chloe/test/test6.xml | 9 + .../server/templating/chloe/test/test7.xml | 9 + .../templating/fhtml/fhtml-tests.factor | 6 +- .../http/server/templating/fhtml/fhtml.factor | 30 ++-- .../http/server/templating/templating.factor | 13 ++ .../http/server/validators/validators.factor | 6 +- extra/xml/writer/writer.factor | 30 ++-- 39 files changed, 854 insertions(+), 397 deletions(-) create mode 100644 extra/http/server/auth/login/boilerplate.xml delete mode 100755 extra/http/server/auth/login/edit-profile.fhtml create mode 100644 extra/http/server/auth/login/edit-profile.xml delete mode 100755 extra/http/server/auth/login/login.fhtml create mode 100644 extra/http/server/auth/login/login.xml delete mode 100755 extra/http/server/auth/login/recover-1.fhtml create mode 100644 extra/http/server/auth/login/recover-1.xml delete mode 100755 extra/http/server/auth/login/recover-2.fhtml create mode 100644 extra/http/server/auth/login/recover-2.xml delete mode 100755 extra/http/server/auth/login/recover-3.fhtml create mode 100644 extra/http/server/auth/login/recover-3.xml delete mode 100755 extra/http/server/auth/login/recover-4.fhtml create mode 100755 extra/http/server/auth/login/recover-4.xml delete mode 100755 extra/http/server/auth/login/register.fhtml create mode 100644 extra/http/server/auth/login/register.xml create mode 100644 extra/http/server/boilerplate/boilerplate.factor create mode 100644 extra/http/server/templating/chloe/chloe-tests.factor create mode 100644 extra/http/server/templating/chloe/chloe.factor create mode 100644 extra/http/server/templating/chloe/test/test1.xml create mode 100644 extra/http/server/templating/chloe/test/test2.xml create mode 100644 extra/http/server/templating/chloe/test/test3-aux.xml create mode 100644 extra/http/server/templating/chloe/test/test3.xml create mode 100644 extra/http/server/templating/chloe/test/test4.xml create mode 100644 extra/http/server/templating/chloe/test/test5.xml create mode 100644 extra/http/server/templating/chloe/test/test6.xml create mode 100644 extra/http/server/templating/chloe/test/test7.xml create mode 100644 extra/http/server/templating/templating.factor diff --git a/extra/editors/vim/generate-syntax/generate-syntax.factor b/extra/editors/vim/generate-syntax/generate-syntax.factor index 178a1b3b8b..325a451a0b 100644 --- a/extra/editors/vim/generate-syntax/generate-syntax.factor +++ b/extra/editors/vim/generate-syntax/generate-syntax.factor @@ -1,9 +1,10 @@ ! Generate a new factor.vim file for syntax highlighting -USING: http.server.templating.fhtml io.files ; +USING: http.server.templating http.server.templating.fhtml +io.files ; IN: editors.vim.generate-syntax : generate-vim-syntax ( -- ) - "misc/factor.vim.fgen" resource-path + "misc/factor.vim.fgen" resource-path "misc/factor.vim" resource-path template-convert ; diff --git a/extra/http/http.factor b/extra/http/http.factor index e792802b5a..c25ae5590d 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -394,14 +394,17 @@ body ; [ unparse-cookies "set-cookie" pick set-at ] when* write-header ; -: write-response-body ( response -- response ) - dup body>> { - { [ dup not ] [ drop ] } - { [ dup string? ] [ write ] } - { [ dup callable? ] [ call ] } - [ stdio get stream-copy ] +: body>quot ( body -- quot ) + { + { [ dup not ] [ drop [ ] ] } + { [ dup string? ] [ [ write ] curry ] } + { [ dup callable? ] [ ] } + [ [ stdio get stream-copy ] curry ] } cond ; +: write-response-body ( response -- response ) + dup body>> body>quot call ; + M: response write-response ( respose -- ) write-response-version write-response-code diff --git a/extra/http/server/auth/login/boilerplate.xml b/extra/http/server/auth/login/boilerplate.xml new file mode 100644 index 0000000000..edc8c329df --- /dev/null +++ b/extra/http/server/auth/login/boilerplate.xml @@ -0,0 +1,9 @@ + + + + +

+ + + + diff --git a/extra/http/server/auth/login/edit-profile.fhtml b/extra/http/server/auth/login/edit-profile.fhtml deleted file mode 100755 index 7d94ca1791..0000000000 --- a/extra/http/server/auth/login/edit-profile.fhtml +++ /dev/null @@ -1,77 +0,0 @@ -<% USING: http.server.components http.server.auth.login -http.server namespaces kernel combinators ; %> - - -

Edit profile

- -
-<% hidden-form-field %> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
User name:<% "username" component render-view %>
Real name:<% "realname" component render-edit %>
Specifying a real name is optional.
Current password:<% "password" component render-edit %>
If you don't want to change your current password, leave this field blank.
New password:<% "new-password" component render-edit %>
Verify:<% "verify-password" component render-edit %>
If you are changing your password, enter it twice to ensure it is correct.
E-mail:<% "email" component render-edit %>
Specifying an e-mail address is optional. It enables the "recover password" feature.
- -

- -<% { - { [ login-failed? get ] [ "invalid password" render-error ] } - { [ password-mismatch? get ] [ "passwords do not match" render-error ] } - { [ t ] [ ] } -} cond %> - -

- -
- - - diff --git a/extra/http/server/auth/login/edit-profile.xml b/extra/http/server/auth/login/edit-profile.xml new file mode 100644 index 0000000000..86a4e86551 --- /dev/null +++ b/extra/http/server/auth/login/edit-profile.xml @@ -0,0 +1,77 @@ + + + + + Edit Profile + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
User name:
Real name:
Specifying a real name is optional.
Current password:
If you don't want to change your current password, leave this field blank.
New password:
Verify:
If you are changing your password, enter it twice to ensure it is correct.
E-mail:
Specifying an e-mail address is optional. It enables the "recover password" feature.
+ +

+ + + + invalid password + + + + passwords do not match + +

+ + + + diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor index 4f04a1ff9b..888234cc96 100755 --- a/extra/http/server/auth/login/login.factor +++ b/extra/http/server/auth/login/login.factor @@ -15,7 +15,9 @@ http.server.actions http.server.components http.server.forms http.server.sessions -http.server.templating.fhtml +http.server.boilerplate +http.server.templating +http.server.templating.chloe http.server.validators ; IN: http.server.auth.login QUALIFIED: smtp @@ -40,11 +42,15 @@ M: user-saver dispose : save-user-after ( user -- ) add-always-destructor ; +: login-template ( name -- template ) + "resource:extra/http/server/auth/login/" swap ".xml" + 3append ; + ! ! ! Login : "login"
- "resource:extra/http/server/auth/login/login.fhtml" >>edit-template + "login" login-template >>edit-template "username" t >>required add-field @@ -86,7 +92,7 @@ M: user-saver dispose : ( -- form ) "register" - "resource:extra/http/server/auth/login/register.fhtml" >>edit-template + "register" login-template >>edit-template "username" t >>required add-field @@ -147,7 +153,7 @@ SYMBOL: user-exists? : ( -- form ) "edit-profile" - "resource:extra/http/server/auth/login/edit-profile.fhtml" >>edit-template + "edit-profile" login-template >>edit-template "username" add-field "realname" add-field "password" add-field @@ -242,7 +248,7 @@ SYMBOL: lost-password-from : ( -- form ) "register" - "resource:extra/http/server/auth/login/recover-1.fhtml" >>edit-template + "recover-1" login-template >>edit-template "username" t >>required add-field @@ -271,13 +277,13 @@ SYMBOL: lost-password-from send-password-email ] when* - "resource:extra/http/server/auth/login/recover-2.fhtml" serve-template + "recover-2" login-template serve-template ] >>submit ] ; : "new-password" - "resource:extra/http/server/auth/login/recover-3.fhtml" >>edit-template + "recover-3" login-template >>edit-template "username" hidden >>renderer t >>required @@ -326,8 +332,7 @@ SYMBOL: lost-password-from "new-password" value >>password users update-user - "resource:extra/http/server/auth/login/recover-4.fhtml" - serve-template + "recover-4" login-template serve-template ] [ <400> ] if* @@ -367,24 +372,32 @@ M: login call-responder ( path responder -- response ) dup login set call-next-method ; +: ( responder -- responder' ) + + "boilerplate" login-template >>template ; + : ( responder -- auth ) login new-dispatcher swap >>default - "login" add-responder - "logout" add-responder + "login" add-responder + "logout" add-responder no-users >>users ; ! ! ! Configuration : allow-edit-profile ( login -- login ) - "edit-profile" add-responder ; + + "edit-profile" add-responder ; : allow-registration ( login -- login ) - "register" add-responder ; + + "register" add-responder ; : allow-password-recovery ( login -- login ) - "recover-password" add-responder - "new-password" add-responder ; + + "recover-password" add-responder + + "new-password" add-responder ; : allow-edit-profile? ( -- ? ) login get responders>> "edit-profile" swap key? ; diff --git a/extra/http/server/auth/login/login.fhtml b/extra/http/server/auth/login/login.fhtml deleted file mode 100755 index 07201719e5..0000000000 --- a/extra/http/server/auth/login/login.fhtml +++ /dev/null @@ -1,46 +0,0 @@ -<% USING: http.server.auth.login http.server.components http.server -kernel namespaces ; %> - - -

Login required

- - - -<% hidden-form-field %> - - - - - - - - - - - - - -
User name:<% "username" component render-edit %>
Password:<% "password" component render-edit %>
- -

-<% -login-failed? get -[ "Invalid username or password" render-error ] when -%> -

- - - -

-<% allow-registration? [ %> - ">Register -<% ] when %> -<% allow-password-recovery? [ %> - "> - Recover Password - -<% ] when %> -

- - - diff --git a/extra/http/server/auth/login/login.xml b/extra/http/server/auth/login/login.xml new file mode 100644 index 0000000000..2f16c09d8d --- /dev/null +++ b/extra/http/server/auth/login/login.xml @@ -0,0 +1,44 @@ + + + + + Login + + + + + + + + + + + + + + + +
User name:
Password:
+ +

+ + + + + invalid username or password + +

+ + + +

+ + Register + + | + + Recover Password + +

+ + diff --git a/extra/http/server/auth/login/recover-1.fhtml b/extra/http/server/auth/login/recover-1.fhtml deleted file mode 100755 index 8ec01f22e9..0000000000 --- a/extra/http/server/auth/login/recover-1.fhtml +++ /dev/null @@ -1,41 +0,0 @@ -<% USING: http.server.components http.server ; %> - - -

Recover lost password: step 1 of 4

- -

Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.

- -
- -<% hidden-form-field %> - - - - - - - - - - - - - - - - - - - - - - - -
User name:<% "username" component render-edit %>
E-mail:<% "email" component render-edit %>
Captcha:<% "captcha" component render-edit %>
Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.
- - - -
- - - diff --git a/extra/http/server/auth/login/recover-1.xml b/extra/http/server/auth/login/recover-1.xml new file mode 100644 index 0000000000..dd3a60f1d1 --- /dev/null +++ b/extra/http/server/auth/login/recover-1.xml @@ -0,0 +1,39 @@ + + + + + Recover lost password: step 1 of 4 + +

Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.

+ + + + + + + + + + + + + + + + + + + + + + + + + +
User name:
E-mail:
Captcha:
Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.
+ + + + + + diff --git a/extra/http/server/auth/login/recover-2.fhtml b/extra/http/server/auth/login/recover-2.fhtml deleted file mode 100755 index 9b13734273..0000000000 --- a/extra/http/server/auth/login/recover-2.fhtml +++ /dev/null @@ -1,9 +0,0 @@ -<% USING: http.server.components ; %> - - -

Recover lost password: step 2 of 4

- -

If you entered the correct username and e-mail address, you should receive an e-mail shortly. Click the link in the e-mail for further instructions.

- - - diff --git a/extra/http/server/auth/login/recover-2.xml b/extra/http/server/auth/login/recover-2.xml new file mode 100644 index 0000000000..c7819bd21b --- /dev/null +++ b/extra/http/server/auth/login/recover-2.xml @@ -0,0 +1,9 @@ + + + + + Recover lost password: step 2 of 4 + +

If you entered the correct username and e-mail address, you should receive an e-mail shortly. Click the link in the e-mail for further instructions.

+ + diff --git a/extra/http/server/auth/login/recover-3.fhtml b/extra/http/server/auth/login/recover-3.fhtml deleted file mode 100755 index ca4823baab..0000000000 --- a/extra/http/server/auth/login/recover-3.fhtml +++ /dev/null @@ -1,46 +0,0 @@ -<% USING: http.server.components http.server.auth.login http.server -namespaces kernel combinators ; %> - - -

Recover lost password: step 3 of 4

- -

Choose a new password for your account.

- -
- -<% hidden-form-field %> - - - -<% "username" component render-edit %> -<% "ticket" component render-edit %> - - - - - - - - - - - - - - - - -
Password:<% "new-password" component render-edit %>
Verify password:<% "verify-password" component render-edit %>
Enter your password twice to ensure it is correct.
- -

- -<% password-mismatch? get [ - "passwords do not match" render-error -] when %> - -

- -
- - - diff --git a/extra/http/server/auth/login/recover-3.xml b/extra/http/server/auth/login/recover-3.xml new file mode 100644 index 0000000000..115c2cea21 --- /dev/null +++ b/extra/http/server/auth/login/recover-3.xml @@ -0,0 +1,43 @@ + + + + + Recover lost password: step 3 of 4 + +

Choose a new password for your account.

+ + + + + + + + + + + + + + + + + + + + + + + +
Password:
Verify password:
Enter your password twice to ensure it is correct.
+ +

+ + + + passwords do not match + +

+ + + + diff --git a/extra/http/server/auth/login/recover-4.fhtml b/extra/http/server/auth/login/recover-4.fhtml deleted file mode 100755 index 239d71d293..0000000000 --- a/extra/http/server/auth/login/recover-4.fhtml +++ /dev/null @@ -1,10 +0,0 @@ -<% USING: http.server ; %> - - -

Recover lost password: step 4 of 4

- -

Your password has been reset. -You may now ">log in.

- - - diff --git a/extra/http/server/auth/login/recover-4.xml b/extra/http/server/auth/login/recover-4.xml new file mode 100755 index 0000000000..3c10869fbd --- /dev/null +++ b/extra/http/server/auth/login/recover-4.xml @@ -0,0 +1,9 @@ + + + + + Recover lost password: step 4 of 4 + +

Your password has been reset. You may now log in.

+ + diff --git a/extra/http/server/auth/login/register.fhtml b/extra/http/server/auth/login/register.fhtml deleted file mode 100755 index 9106497def..0000000000 --- a/extra/http/server/auth/login/register.fhtml +++ /dev/null @@ -1,77 +0,0 @@ -<% USING: http.server.components http.server.auth.login -http.server namespaces kernel combinators ; %> - - -

New user registration

- -
-<% hidden-form-field %> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
User name:<% "username" component render-edit %>
Real name:<% "realname" component render-edit %>
Specifying a real name is optional.
Password:<% "new-password" component render-edit %>
Verify:<% "verify-password" component render-edit %>
Enter your password twice to ensure it is correct.
E-mail:<% "email" component render-edit %>
Specifying an e-mail address is optional. It enables the "recover password" feature.
Captcha:<% "captcha" component render-edit %>
Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.
- -

- -<% { - { [ password-mismatch? get ] [ "passwords do not match" render-error ] } - { [ user-exists? get ] [ "username taken" render-error ] } - { [ t ] [ ] } -} cond %> - -

- -
- - - diff --git a/extra/http/server/auth/login/register.xml b/extra/http/server/auth/login/register.xml new file mode 100644 index 0000000000..1bacf71801 --- /dev/null +++ b/extra/http/server/auth/login/register.xml @@ -0,0 +1,79 @@ + + + + + New User Registration + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
User name:
Real name:
Specifying a real name is optional.
Password:
Verify:
Enter your password twice to ensure it is correct.
E-mail:
Specifying an e-mail address is optional. It enables the "recover password" feature.
Captcha:
Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.
+ +

+ + + + + username taken + + + + passwords do not match + + +

+ + + + diff --git a/extra/http/server/boilerplate/boilerplate.factor b/extra/http/server/boilerplate/boilerplate.factor new file mode 100644 index 0000000000..2bd6eee340 --- /dev/null +++ b/extra/http/server/boilerplate/boilerplate.factor @@ -0,0 +1,49 @@ +! Copyright (c) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel namespaces boxes sequences strings +io io.streams.string +http.server +http.server.templating ; +IN: http.server.boilerplate + +TUPLE: boilerplate responder template ; + +: f boilerplate boa ; + +SYMBOL: title + +: set-title ( string -- ) + title get >box ; + +: write-title ( -- ) + title get value>> write ; + +SYMBOL: style + +: add-style ( string -- ) + "\n" style get push-all + style get push-all ; + +: write-style ( -- ) + style get >string write ; + +SYMBOL: next-template + +: call-next-template ( -- ) + next-template get write ; + +M: f call-template drop call-next-template ; + +: with-boilerplate ( body template -- ) + [ + title get [ title set ] unless + style get [ SBUF" " clone style set ] unless + + swap with-string-writer next-template set + + call-template + ] with-scope ; inline + +M: boilerplate call-responder + [ responder>> call-responder clone ] [ template>> ] bi + [ [ with-boilerplate ] 2curry ] curry change-body ; diff --git a/extra/http/server/components/components-tests.factor b/extra/http/server/components/components-tests.factor index f1c43fe8ae..29cfa1de8b 100755 --- a/extra/http/server/components/components-tests.factor +++ b/extra/http/server/components/components-tests.factor @@ -2,6 +2,7 @@ IN: http.server.components.tests USING: http.server.components http.server.forms http.server.validators namespaces tools.test kernel accessors tuple-syntax mirrors http.server.actions +http.server.templating.fhtml io.streams.string io.streams.null ; \ render-edit must-infer @@ -49,8 +50,8 @@ TUPLE: test-tuple text number more-text ; : ( -- form ) "test"
- "resource:extra/http/server/components/test/form.fhtml" >>view-template - "resource:extra/http/server/components/test/form.fhtml" >>edit-template + "resource:extra/http/server/components/test/form.fhtml" >>view-template + "resource:extra/http/server/components/test/form.fhtml" >>edit-template "text" t >>required add-field diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor index 1e5e33c4a0..3ab0bdd770 100755 --- a/extra/http/server/components/components.factor +++ b/extra/http/server/components/components.factor @@ -203,22 +203,35 @@ M: captcha validate* drop v-captcha ; ! Text areas -TUPLE: textarea-renderer ; +TUPLE: textarea-renderer rows cols ; -: textarea-renderer T{ textarea-renderer } ; +: new-textarea-renderer ( class -- renderer ) + new + 60 >>cols + 20 >>rows ; + +: ( -- renderer ) + textarea-renderer new-textarea-renderer ; M: textarea-renderer render-view* drop write ; M: textarea-renderer render-edit* - drop ; + ; TUPLE: text < string ; : new-text ( id class -- component ) new-string f >>one-line - textarea-renderer >>renderer ; + >>renderer ; : ( id -- component ) text new-text ; diff --git a/extra/http/server/components/farkup/farkup.factor b/extra/http/server/components/farkup/farkup.factor index 65e159513d..fb1c6fd25a 100755 --- a/extra/http/server/components/farkup/farkup.factor +++ b/extra/http/server/components/farkup/farkup.factor @@ -6,11 +6,12 @@ IN: http.server.components.farkup TUPLE: farkup-renderer < textarea-renderer ; -: farkup-renderer T{ farkup-renderer } ; +: + farkup-renderer new-textarea-renderer ; M: farkup-renderer render-view* drop string-lines "\n" join convert-farkup write ; : ( id -- component ) - farkup-renderer >>renderer ; + >>renderer ; diff --git a/extra/http/server/crud/crud.factor b/extra/http/server/crud/crud.factor index eb8ff943c7..cf9771e15f 100755 --- a/extra/http/server/crud/crud.factor +++ b/extra/http/server/crud/crud.factor @@ -23,29 +23,18 @@ IN: http.server.crud : ( id next -- response ) swap number>string "id" associate ; -:: ( form ctor next -- action ) - - [ f ctor call from-tuple form set-defaults ] >>init - - [ - "text/html" - [ form edit-form ] >>body - ] >>display - - [ - f ctor call from-tuple - - form validate-form - - values-tuple insert-tuple - - "id" value next - ] >>submit ; - :: ( form ctor next -- action ) - { { "id" [ v-number ] } } >>get-params - [ "id" get ctor call select-tuple from-tuple ] >>init + { { "id" [ [ v-number ] v-optional ] } } >>get-params + + [ + "id" get ctor call + + "id" get + [ select-tuple from-tuple ] + [ from-tuple form set-defaults ] + if + ] >>init [ "text/html" @@ -57,7 +46,8 @@ IN: http.server.crud form validate-form - values-tuple update-tuple + values-tuple + "id" value [ update-tuple ] [ insert-tuple ] if "id" value next ] >>submit ; @@ -71,3 +61,16 @@ IN: http.server.crud next f ] >>submit ; + +:: ( form ctor -- action ) + + [ + "text/html" + [ + blank-values + + f ctor call select-tuples "list" set-value + + form view-form + ] >>body + ] >>display ; diff --git a/extra/http/server/forms/forms.factor b/extra/http/server/forms/forms.factor index cf8fd4ca8c..2c2b673f83 100644 --- a/extra/http/server/forms/forms.factor +++ b/extra/http/server/forms/forms.factor @@ -1,11 +1,13 @@ -USING: kernel accessors assocs namespaces io.files fry +USING: kernel accessors assocs namespaces io.files sequences fry http.server.actions http.server.components http.server.validators -http.server.templating.fhtml ; +http.server.templating ; IN: http.server.forms -TUPLE: form < component view-template edit-template components ; +TUPLE: form < component +view-template edit-template summary-template +components ; M: form init V{ } clone >>components ; @@ -28,10 +30,13 @@ M: form init V{ } clone >>components ; ] with-form ; : view-form ( form -- ) - dup view-template>> '[ , run-template ] with-form ; + dup view-template>> '[ , call-template ] with-form ; : edit-form ( form -- ) - dup edit-template>> '[ , run-template ] with-form ; + dup edit-template>> '[ , call-template ] with-form ; + +: summary-form ( form -- ) + dup summary-template>> '[ , call-template ] with-form ; : validate-param ( id component -- ) [ [ params get at ] [ validate ] bi* ] @@ -46,3 +51,20 @@ M: form init V{ } clone >>components ; : validate-form ( form -- ) (validate-form) [ validation-failed ] when ; + +! List components +TUPLE: list-renderer form ; + +C: list-renderer + +M: list-renderer render-view* + form>> [ + [ >r from-tuple r> summary-form ] with-scope + ] curry each ; + +TUPLE: list < component ; + +: ( id form -- list ) + list swap new-component ; + +M: list component-string drop ; diff --git a/extra/http/server/templating/chloe/chloe-tests.factor b/extra/http/server/templating/chloe/chloe-tests.factor new file mode 100644 index 0000000000..f517af4a12 --- /dev/null +++ b/extra/http/server/templating/chloe/chloe-tests.factor @@ -0,0 +1,97 @@ +USING: http.server.templating http.server.templating.chloe +http.server.components http.server.boilerplate tools.test +io.streams.string kernel sequences ascii boxes namespaces xml +splitting ; +IN: http.server.templating.chloe.tests + +[ "foo" ] +[ "blah" string>xml "href" required-attr ] +unit-test + +[ "blah" string>xml "href" required-attr ] +[ "href attribute is required" = ] +must-fail-with + +[ f ] [ f parse-query-attr ] unit-test + +[ f ] [ "" parse-query-attr ] unit-test + +[ H{ { "a" "b" } } ] [ + blank-values + "b" "a" set-value + "a" parse-query-attr +] unit-test + +[ H{ { "a" "b" } { "c" "d" } } ] [ + blank-values + "b" "a" set-value + "d" "c" set-value + "a,c" parse-query-attr +] unit-test + +: run-template + with-string-writer [ "\r\n\t" member? not ] subset + "?>" split1 nip ; inline + +: test-template ( name -- template ) + "resource:extra/http/server/templating/chloe/test/" + swap + ".xml" 3append ; + +[ "Hello world" ] [ + [ + "test1" test-template call-template + ] run-template +] unit-test + +[ "Blah blah" "Hello world" ] [ + [ + title set + [ + "test2" test-template call-template + ] run-template + title get box> + ] with-scope +] unit-test + +[ "Hello worldBlah blah" ] [ + [ + [ + "test2" test-template call-template + ] "test3" test-template with-boilerplate + ] run-template +] unit-test + +: test4-aux? t ; + +[ "True" ] [ + [ + "test4" test-template call-template + ] run-template +] unit-test + +: test5-aux? f ; + +[ "" ] [ + [ + "test5" test-template call-template + ] run-template +] unit-test + +SYMBOL: test6-aux? + +[ "True" ] [ + [ + test6-aux? on + "test6" test-template call-template + ] run-template +] unit-test + +SYMBOL: test7-aux? + +[ "" ] [ + [ + test7-aux? off + "test7" test-template call-template + ] run-template +] unit-test diff --git a/extra/http/server/templating/chloe/chloe.factor b/extra/http/server/templating/chloe/chloe.factor new file mode 100644 index 0000000000..9da153607f --- /dev/null +++ b/extra/http/server/templating/chloe/chloe.factor @@ -0,0 +1,168 @@ +USING: accessors kernel sequences combinators kernel namespaces +classes.tuple assocs splitting words arrays +io.files io.encodings.utf8 html.elements unicode.case +tuple-syntax xml xml.data xml.writer xml.utilities +http.server +http.server.auth +http.server.components +http.server.sessions +http.server.templating +http.server.boilerplate ; +IN: http.server.templating.chloe + +! Chloe is Ed's favorite web designer + +TUPLE: chloe path ; + +C: chloe + +DEFER: process-template + +: chloe-ns TUPLE{ name url: "http://factorcode.org/chloe/1.0" } ; + +: chloe-tag? ( tag -- ? ) + { + { [ dup tag? not ] [ f ] } + { [ dup chloe-ns names-match? not ] [ f ] } + [ t ] + } cond nip ; + +SYMBOL: tags + +: required-attr ( tag name -- value ) + dup rot at* + [ nip ] [ drop " attribute is required" append throw ] if ; + +: optional-attr ( tag name -- value ) + swap at ; + +: write-title-tag ( tag -- ) + drop + "head" tags get member? "title" tags get member? not and + [ write-title ] [ write-title ] if ; + +: style-tag ( tag -- ) + dup "include" optional-attr dup [ + swap children>string empty? [ + "style tag cannot have both an include attribute and a body" throw + ] unless + utf8 file-contents + ] [ + drop children>string + ] if add-style ; + +: write-style-tag ( tag -- ) + drop ; + +: component-attr ( tag -- name ) + "component" required-attr ; + +: view-tag ( tag -- ) + component-attr component render-view ; + +: edit-tag ( tag -- ) + component-attr component render-edit ; + +: parse-query-attr ( string -- assoc ) + dup empty? + [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ; + +: a-start-tag ( tag -- ) + string =href + a> ; + +: process-tag-children ( tag -- ) + [ process-template ] each ; + +: a-tag ( tag -- ) + [ a-start-tag ] + [ process-tag-children ] + [ drop ] + tri ; + +: form-start-tag ( tag -- ) + + hidden-form-field ; + +: form-tag ( tag -- ) + [ form-start-tag ] + [ process-tag-children ] + [ drop ] + tri ; + +: attr>word ( value -- word/f ) + dup ":" split1 swap lookup + [ ] [ "No such word: " swap append throw ] ?if ; + +: attr>var ( value -- word/f ) + attr>word dup symbol? [ + "Must be a symbol: " swap append throw + ] unless ; + +: if-satisfied? ( tag -- ? ) + { + [ "code" optional-attr [ attr>word execute ] [ t ] if* ] + [ "var" optional-attr [ attr>var get ] [ t ] if* ] + [ "svar" optional-attr [ attr>var sget ] [ t ] if* ] + [ "uvar" optional-attr [ attr>var uget ] [ t ] if* ] + } cleave 4array [ ] all? ; + +: if-tag ( tag -- ) + dup if-satisfied? [ process-tag-children ] [ drop ] if ; + +: error-tag ( tag -- ) + children>string render-error ; + +: process-chloe-tag ( tag -- ) + dup name-tag { + { "chloe" [ [ process-template ] each ] } + { "title" [ children>string set-title ] } + { "write-title" [ write-title-tag ] } + { "style" [ style-tag ] } + { "write-style" [ write-style-tag ] } + { "view" [ view-tag ] } + { "edit" [ edit-tag ] } + { "a" [ a-tag ] } + { "form" [ form-tag ] } + { "error" [ error-tag ] } + { "if" [ if-tag ] } + { "call-next-template" [ drop call-next-template ] } + [ "Unknown chloe tag: " swap append throw ] + } case ; + +: process-tag ( tag -- ) + { + [ name-tag >lower tags get push ] + [ write-start-tag ] + [ process-tag-children ] + [ write-end-tag ] + [ drop tags get pop* ] + } cleave ; + +: process-template ( xml -- ) + { + { [ dup [ chloe-tag? ] is? ] [ process-chloe-tag ] } + { [ dup [ tag? ] is? ] [ process-tag ] } + { [ t ] [ write-item ] } + } cond ; + +: process-chloe ( xml -- ) + [ + V{ } clone tags set + + { + [ xml-prolog write-prolog ] + [ xml-before write-chunk ] + [ process-template ] + [ xml-after write-chunk ] + } cleave + ] with-scope ; + +M: chloe call-template + path>> utf8 read-xml process-chloe ; diff --git a/extra/http/server/templating/chloe/test/test1.xml b/extra/http/server/templating/chloe/test/test1.xml new file mode 100644 index 0000000000..daccd57b17 --- /dev/null +++ b/extra/http/server/templating/chloe/test/test1.xml @@ -0,0 +1,5 @@ + + + + Hello world + diff --git a/extra/http/server/templating/chloe/test/test2.xml b/extra/http/server/templating/chloe/test/test2.xml new file mode 100644 index 0000000000..05b9dde54f --- /dev/null +++ b/extra/http/server/templating/chloe/test/test2.xml @@ -0,0 +1,6 @@ + + + + Hello world + Blah blah + diff --git a/extra/http/server/templating/chloe/test/test3-aux.xml b/extra/http/server/templating/chloe/test/test3-aux.xml new file mode 100644 index 0000000000..99f61afe33 --- /dev/null +++ b/extra/http/server/templating/chloe/test/test3-aux.xml @@ -0,0 +1,5 @@ + + + + Hello world + diff --git a/extra/http/server/templating/chloe/test/test3.xml b/extra/http/server/templating/chloe/test/test3.xml new file mode 100644 index 0000000000..845dd356c9 --- /dev/null +++ b/extra/http/server/templating/chloe/test/test3.xml @@ -0,0 +1,12 @@ + + + + + + + + + + + + diff --git a/extra/http/server/templating/chloe/test/test4.xml b/extra/http/server/templating/chloe/test/test4.xml new file mode 100644 index 0000000000..0381bcc27a --- /dev/null +++ b/extra/http/server/templating/chloe/test/test4.xml @@ -0,0 +1,9 @@ + + + + + + True + + + diff --git a/extra/http/server/templating/chloe/test/test5.xml b/extra/http/server/templating/chloe/test/test5.xml new file mode 100644 index 0000000000..d74a5e5368 --- /dev/null +++ b/extra/http/server/templating/chloe/test/test5.xml @@ -0,0 +1,9 @@ + + + + + + True + + + diff --git a/extra/http/server/templating/chloe/test/test6.xml b/extra/http/server/templating/chloe/test/test6.xml new file mode 100644 index 0000000000..5b6a71cf6b --- /dev/null +++ b/extra/http/server/templating/chloe/test/test6.xml @@ -0,0 +1,9 @@ + + + + + + True + + + diff --git a/extra/http/server/templating/chloe/test/test7.xml b/extra/http/server/templating/chloe/test/test7.xml new file mode 100644 index 0000000000..4381b5cec4 --- /dev/null +++ b/extra/http/server/templating/chloe/test/test7.xml @@ -0,0 +1,9 @@ + + + + + + True + + + diff --git a/extra/http/server/templating/fhtml/fhtml-tests.factor b/extra/http/server/templating/fhtml/fhtml-tests.factor index 9d8a6f4617..42bec43570 100755 --- a/extra/http/server/templating/fhtml/fhtml-tests.factor +++ b/extra/http/server/templating/fhtml/fhtml-tests.factor @@ -1,13 +1,13 @@ USING: io io.files io.streams.string io.encodings.utf8 -http.server.templating.fhtml kernel tools.test sequences -parser ; +http.server.templating http.server.templating.fhtml kernel +tools.test sequences parser ; IN: http.server.templating.fhtml.tests : test-template ( path -- ? ) "resource:extra/http/server/templating/fhtml/test/" prepend [ - ".fhtml" append [ run-template ] with-string-writer + ".fhtml" append [ call-template ] with-string-writer ] keep ".html" append utf8 file-contents = ; diff --git a/extra/http/server/templating/fhtml/fhtml.factor b/extra/http/server/templating/fhtml/fhtml.factor index 4a3bf38e23..237931dc34 100755 --- a/extra/http/server/templating/fhtml/fhtml.factor +++ b/extra/http/server/templating/fhtml/fhtml.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2005 Alex Chapman ! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: continuations sequences kernel parser namespaces io -io.files io.streams.string html html.elements source-files -debugger combinators math quotations generic strings splitting -accessors http.server.static http.server assocs -io.encodings.utf8 fry accessors ; - +USING: continuations sequences kernel namespaces debugger +combinators math quotations generic strings splitting +accessors assocs fry +parser io io.files io.streams.string io.encodings.utf8 source-files +html html.elements +http.server.static http.server http.server.templating ; IN: http.server.templating.fhtml : templating-vocab ( -- vocab-name ) "http.server.templating.fhtml" ; @@ -72,9 +72,13 @@ DEFER: <% delimiter : html-error. ( error -- ) 
 error.
; -: run-template ( filename -- ) +TUPLE: fhtml path ; + +C: fhtml + +M: fhtml call-template ( filename -- ) '[ - , [ + , path>> [ "quiet" on parser-notes off templating-vocab use+ @@ -85,16 +89,8 @@ DEFER: <% delimiter ] with-file-vocabs ] assert-depth ; -: template-convert ( infile outfile -- ) - utf8 [ run-template ] with-file-writer ; - -! responder integration -: serve-template ( name -- response ) - "text/html" - swap '[ , run-template ] >>body ; - ! file responder integration : enable-fhtml ( responder -- responder ) - [ serve-template ] + [ serve-template ] "application/x-factor-server-page" pick special>> set-at ; diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor new file mode 100644 index 0000000000..378823e9d1 --- /dev/null +++ b/extra/http/server/templating/templating.factor @@ -0,0 +1,13 @@ +USING: accessors kernel fry io.encodings.utf8 io.files +http.server ; +IN: http.server.templating + +GENERIC: call-template ( template -- ) + +: template-convert ( template output -- ) + utf8 [ call-template ] with-file-writer ; + +! responder integration +: serve-template ( template -- response ) + "text/html" + swap '[ , call-template ] >>body ; diff --git a/extra/http/server/validators/validators.factor b/extra/http/server/validators/validators.factor index 5be064c5ce..692a5dec7c 100755 --- a/extra/http/server/validators/validators.factor +++ b/extra/http/server/validators/validators.factor @@ -11,8 +11,7 @@ TUPLE: validation-error value reason ; C: validation-error : with-validator ( value quot -- result ) - [ validation-failed? on ] recover ; - inline + [ validation-failed? on ] recover ; inline : v-default ( str def -- str ) over empty? spin ? ; @@ -20,6 +19,9 @@ C: validation-error : v-required ( str -- str ) dup empty? [ "required" throw ] when ; +: v-optional ( str quot -- str ) + over empty? [ 2drop f ] [ call ] if ; inline + : v-min-length ( str n -- str ) over length over < [ [ "must be at least " % # " characters" % ] "" make diff --git a/extra/xml/writer/writer.factor b/extra/xml/writer/writer.factor index 27880da07f..44c92006a0 100644 --- a/extra/xml/writer/writer.factor +++ b/extra/xml/writer/writer.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: hashtables kernel math namespaces sequences strings -io io.streams.string xml.data assocs wrap xml.entities -unicode.categories ; +assocs combinators io io.streams.string +xml.data wrap xml.entities unicode.categories ; IN: xml.writer SYMBOL: xml-pprint? @@ -61,6 +61,9 @@ M: string write-item ?indent CHAR: < write1 dup print-name tag-attrs print-attrs ; +: write-start-tag ( tag -- ) + write-tag ">" write ; + M: contained-tag write-item write-tag "/>" write ; @@ -72,11 +75,14 @@ M: contained-tag write-item ?indent " write1 ; M: open-tag write-item - xml-pprint? [ [ - over sensitive? not and xml-pprint? set - dup write-tag CHAR: > write1 - dup write-children write-end-tag - ] keep ] change ; + xml-pprint? get >r + { + [ sensitive? not xml-pprint? get and xml-pprint? set ] + [ write-start-tag ] + [ write-children ] + [ write-end-tag ] + } cleave + r> xml-pprint? set ; M: comment write-item "" write ; @@ -97,10 +103,12 @@ M: instruction write-item [ write-item ] each ; : write-xml ( xml -- ) - dup xml-prolog write-prolog - dup xml-before write-chunk - dup write-item - xml-after write-chunk ; + { + [ xml-prolog write-prolog ] + [ xml-before write-chunk ] + [ write-item ] + [ xml-after write-chunk ] + } cleave ; : print-xml ( xml -- ) write-xml nl ; From cd0b715161aceb7065b8ef4713948194d00a0877 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 15 Apr 2008 06:19:39 -0500 Subject: [PATCH 005/145] Use 
 tags

---
 extra/farkup/farkup.factor | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor
index f876c9569b..b98f6c6954 100755
--- a/extra/farkup/farkup.factor
+++ b/extra/farkup/farkup.factor
@@ -55,7 +55,8 @@ MEMO: eq ( -- parser )
 
 : render-code ( string mode -- string' )
     >r string-lines r>
-    [ [ htmlize-lines ] with-html-stream ] with-string-writer ;
+    [ [ htmlize-lines ] with-html-stream ] with-string-writer
+    "pre" surround-with-foo ;
 
 : escape-link ( href text -- href-esc text-esc )
     >r escape-quoted-string r> escape-string ;

From dd42130aed7649c77e6be50fbe56971b48b7badc Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Tue, 15 Apr 2008 06:23:15 -0500
Subject: [PATCH 006/145] Fix farkup tests

---
 extra/farkup/farkup-tests.factor |  2 +-
 extra/farkup/farkup.factor       | 17 +++++++++++------
 2 files changed, 12 insertions(+), 7 deletions(-)

diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor
index af4ddd8839..8dc590449e 100755
--- a/extra/farkup/farkup-tests.factor
+++ b/extra/farkup/farkup-tests.factor
@@ -54,7 +54,7 @@ IN: farkup.tests
 [ "
=
foo
" ] [ "===foo==" convert-farkup ] unit-test
 [ "
foo
=
" ] [ "=foo==" convert-farkup ] unit-test
 
-[ "int main()
" ]
+[ "
int main()
" ]
 [ "[c{int main()}]" convert-farkup ] unit-test
 
 [ "
" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor
index b98f6c6954..527ba8b4fa 100755
--- a/extra/farkup/farkup.factor
+++ b/extra/farkup/farkup.factor
@@ -1,9 +1,9 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays io kernel memoize namespaces peg sequences strings
-html.elements xml.entities xmode.code2html splitting
-io.streams.string html peg.parsers html.elements sequences.deep
-unicode.categories ;
+USING: arrays io io.styles kernel memoize namespaces peg
+sequences strings html.elements xml.entities xmode.code2html
+splitting io.streams.string html peg.parsers html.elements
+sequences.deep unicode.categories ;
 IN: farkup
 
 r string-lines r>
-    [ [ htmlize-lines ] with-html-stream ] with-string-writer
-    "pre" surround-with-foo ;
+    [
+        [
+            H{ { wrap-margin f } } [
+                htmlize-lines
+            ] with-nesting
+        ] with-html-stream
+    ] with-string-writer ;
 
 : escape-link ( href text -- href-esc text-esc )
     >r escape-quoted-string r> escape-string ;

From c0206b3165ecc1f8ab3424d4c51ad05c98e16f25 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Tue, 15 Apr 2008 06:35:06 -0500
Subject: [PATCH 007/145] Adding todo webapp

---
 extra/webapps/todo/edit-todo.xml    |  26 +++++++
 extra/webapps/todo/page.xml         |  45 +++++++++++
 extra/webapps/todo/todo-list.xml    |  12 +++
 extra/webapps/todo/todo-summary.xml |  20 +++++
 extra/webapps/todo/todo.css         |  41 ++++++++++
 extra/webapps/todo/todo.factor      | 111 ++++++++++++++++++++++++++++
 extra/webapps/todo/todo.xml         |  26 +++++++
 extra/webapps/todo/view-todo.xml    |  23 ++++++
 8 files changed, 304 insertions(+)
 create mode 100644 extra/webapps/todo/edit-todo.xml
 create mode 100644 extra/webapps/todo/page.xml
 create mode 100644 extra/webapps/todo/todo-list.xml
 create mode 100644 extra/webapps/todo/todo-summary.xml
 create mode 100644 extra/webapps/todo/todo.css
 create mode 100755 extra/webapps/todo/todo.factor
 create mode 100644 extra/webapps/todo/todo.xml
 create mode 100644 extra/webapps/todo/view-todo.xml

diff --git a/extra/webapps/todo/edit-todo.xml b/extra/webapps/todo/edit-todo.xml
new file mode 100644
index 0000000000..71d6900f1a
--- /dev/null
+++ b/extra/webapps/todo/edit-todo.xml
@@ -0,0 +1,26 @@
+
+
+
+
+	Edit Item
+
+	
+		
+
+		
+			
+			
+			
+		
Summary:    
Priority:   
Description:

+
+		
+	
+
+	View
+	|
+	
+		
+		
+	
+
+
diff --git a/extra/webapps/todo/page.xml b/extra/webapps/todo/page.xml
new file mode 100644
index 0000000000..f40c79d299
--- /dev/null
+++ b/extra/webapps/todo/page.xml
@@ -0,0 +1,45 @@
+
+
+
+
+
+
+	
+
+		
+			
+
+			
+				body, button {
+					font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
+					color:#444;
+				}
+
+				a, .link {
+					color: #222;
+					border-bottom:1px dotted #666;
+					text-decoration:none;
+				}
+				
+				a:hover, .link:hover {
+					border-bottom:1px solid #66a;
+				}
+
+				.error { color: #a00; }
+				
+				.field-label {
+					text-align: right;
+				}
+			
+
+			
+		
+
+		
+			
+		
+
+	
+
+
diff --git a/extra/webapps/todo/todo-list.xml b/extra/webapps/todo/todo-list.xml
new file mode 100644
index 0000000000..056a9c6242
--- /dev/null
+++ b/extra/webapps/todo/todo-list.xml
@@ -0,0 +1,12 @@
+
+
+
+
+	My Todo List
+
+	
+		
+		
+	
SummaryPriorityViewEdit

+
+
diff --git a/extra/webapps/todo/todo-summary.xml b/extra/webapps/todo/todo-summary.xml
new file mode 100644
index 0000000000..9e03b7f135
--- /dev/null
+++ b/extra/webapps/todo/todo-summary.xml
@@ -0,0 +1,20 @@
+
+
+
+
+	
+		
+			
+		
+		
+			
+		
+		
+			View
+		
+		
+			Edit
+		
+	
+
+
diff --git a/extra/webapps/todo/todo.css b/extra/webapps/todo/todo.css
new file mode 100644
index 0000000000..f7a6cfa1a2
--- /dev/null
+++ b/extra/webapps/todo/todo.css
@@ -0,0 +1,41 @@
+.big-field-label {
+	vertical-align: top;
+}
+
+.description {
+	border: 1px dashed #ccc;
+	background-color: #f5f5f5;
+	padding: 5px;
+	font-size: 150%;
+	color: #000000;3
+}
+
+.link-button {
+	padding: 0px;
+	background: none;
+	border: none;
+}
+
+.navbar {
+	background-color: #eeeeee;
+	padding: 5px;
+	border: 1px solid #ccc;
+}
+
+.inline {
+	display: inline;
+}
+
+pre {
+	font-size: 75%;
+}
+
+.todo-list {
+	border-style: none;
+}
+
+.todo-list td, .todo-list th {
+	border-width: 1px;
+	padding: 2px;
+	border-style: solid;
+}
diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor
new file mode 100755
index 0000000000..6277216eef
--- /dev/null
+++ b/extra/webapps/todo/todo.factor
@@ -0,0 +1,111 @@
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel locals sequences
+db db.types db.tuples
+http.server.components http.server.components.farkup
+http.server.forms http.server.templating.chloe
+http.server.boilerplate http.server.crud http.server.auth
+http.server.actions http.server.db
+http.server ;
+IN: todo
+
+TUPLE: todo uid id priority summary description ;
+
+todo "TODO"
+{
+    { "uid" "UID" { VARCHAR 256 } +not-null+ }
+    { "id" "ID" +native-id+ }
+    { "priority" "PRIORITY" INTEGER +not-null+ }
+    { "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
+    { "description" "DESCRIPTION" { VARCHAR 256 } }
+} define-persistent
+
+: init-todo-table todo ensure-table ;
+
+:  ( id -- todo )
+    todo new
+        swap >>id
+        uid >>uid ;
+
+: todo-template ( name -- template )
+    "resource:extra/webapps/todo/" swap ".xml" 3append  ;
+
+:  ( -- form )
+    "todo" 

+        "view-todo" todo-template >>view-template
+        "edit-todo" todo-template >>edit-template
+        "todo-summary" todo-template >>summary-template
+        "id" 
+            hidden >>renderer
+            add-field
+        "summary" 
+            t >>required
+            add-field
+        "priority" 
+            t >>required
+            0 >>default
+            0 >>min-value
+            10 >>max-value
+            add-field
+        "description" 
+            add-field ;
+
+:  ( -- form )
+    "todo-list" 
+        "todo-list" todo-template >>view-template
+        "list"  
+        add-field ;
+
+TUPLE: todo-responder < dispatcher ;
+
+::  ( -- responder )
+    [let | todo-form [  ]
+           list-form [  ]
+           ctor [ [  ] ] |
+        todo-responder new-dispatcher
+            list-form ctor           "list"   add-main-responder
+            todo-form ctor           "view"   add-responder
+            todo-form ctor "view"    "edit"   add-responder
+                      ctor "list"  "delete" add-responder
+        
+            "todo" todo-template >>template
+    ] ;
+
+! What follows below is somewhat akin to a 'deployment descriptor'
+! for the todo application. The  can be integrated
+! into an existing web app that provides session management and
+! login facilities, or  can be used to run a
+! self-contained todo instance.
+USING: namespaces io.files io.sockets
+db.sqlite smtp
+http.server.sessions
+http.server.auth.login
+http.server.auth.providers.db
+http.server.sessions.storage.db ;
+
+: test-db "todo.db" resource-path sqlite-db ;
+
+:  ( -- responder )
+    
+    
+        users-in-db >>users
+        allow-registration
+        allow-password-recovery
+        allow-edit-profile
+    
+        "page" todo-template >>template
+    
+        sessions-in-db >>sessions
+    test-db  ;
+
+: init-todo ( -- )
+    "factorcode.org" 25  smtp-server set-global
+    "todo@factorcode.org" lost-password-from set-global
+
+    test-db [
+        init-todo-table
+        init-users-table
+        init-sessions-table
+    ] with-db
+
+     main-responder set-global ;
diff --git a/extra/webapps/todo/todo.xml b/extra/webapps/todo/todo.xml
new file mode 100644
index 0000000000..a76ed2730f
--- /dev/null
+++ b/extra/webapps/todo/todo.xml
@@ -0,0 +1,26 @@
+
+
+
+
+	
+
+	
+
+	

+		  List Items
+		| New Items
+
+		
+			| Edit Profile
+		
+
+		
+			| 
+		
+	

+
+	

+
+	
+
+
diff --git a/extra/webapps/todo/view-todo.xml b/extra/webapps/todo/view-todo.xml
new file mode 100644
index 0000000000..fea77c1189
--- /dev/null
+++ b/extra/webapps/todo/view-todo.xml
@@ -0,0 +1,23 @@
+
+
+
+
+	View Item
+
+	
+		
+		
+	
Summary:    
Priority:   

+
+	

+		
+	

+
+	Edit
+	|
+	
+		
+		
+	
+
+

From 783d0d613d3389af5108ff917178bb0eaa2408dd Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Tue, 15 Apr 2008 07:09:01 -0500
Subject: [PATCH 008/145] Fix todo app

---
 extra/webapps/todo/todo.factor | 8 +++++---
 extra/webapps/todo/todo.xml    | 2 +-
 2 files changed, 6 insertions(+), 4 deletions(-)

diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor
index 6277216eef..d8d9988109 100755
--- a/extra/webapps/todo/todo.factor
+++ b/extra/webapps/todo/todo.factor
@@ -7,7 +7,7 @@ http.server.forms http.server.templating.chloe
 http.server.boilerplate http.server.crud http.server.auth
 http.server.actions http.server.db
 http.server ;
-IN: todo
+IN: webapps.todo
 
 TUPLE: todo uid id priority summary description ;
 
@@ -86,7 +86,7 @@ http.server.sessions.storage.db ;
 : test-db "todo.db" resource-path sqlite-db ;
 
 :  ( -- responder )
-    
+    
     
         users-in-db >>users
         allow-registration
@@ -108,4 +108,6 @@ http.server.sessions.storage.db ;
         init-sessions-table
     ] with-db
 
-     main-responder set-global ;
+    
+         "todo" add-responder
+    main-responder set-global ;
diff --git a/extra/webapps/todo/todo.xml b/extra/webapps/todo/todo.xml
index a76ed2730f..81a5d3a425 100644
--- a/extra/webapps/todo/todo.xml
+++ b/extra/webapps/todo/todo.xml
@@ -8,7 +8,7 @@
 
 	

 		  List Items
-		| New Items
+		| Add Item
 
 		
 			| Edit Profile

From defc1cfae97329b0aade66049093235a32485601 Mon Sep 17 00:00:00 2001
From: Doug Coleman 
Date: Tue, 15 Apr 2008 21:55:26 -0500
Subject: [PATCH 009/145] fix sql

---
 extra/db/sql/sql-tests.factor |  2 +-
 extra/db/sql/sql.factor       | 34 +++++++++++++++++-----------------
 2 files changed, 18 insertions(+), 18 deletions(-)

diff --git a/extra/db/sql/sql-tests.factor b/extra/db/sql/sql-tests.factor
index 488026fcc7..db69d71a84 100644
--- a/extra/db/sql/sql-tests.factor
+++ b/extra/db/sql/sql-tests.factor
@@ -28,7 +28,7 @@ TUPLE: person name age ;
                     { select
                         { columns "salary" }
                         { from "staff" }
-                        { where { "branchno" "b003" } }
+                        { where { "branchno" = "b003" } }
                     }
                 }
                 { "branchno" > 3 } }
diff --git a/extra/db/sql/sql.factor b/extra/db/sql/sql.factor
index 26e8429efd..b0ec7aaf34 100755
--- a/extra/db/sql/sql.factor
+++ b/extra/db/sql/sql.factor
@@ -27,23 +27,23 @@ DEFER: sql%
 : sql-array% ( array -- )
     unclip
     {
-        { columns [ "," (sql-interleave) ] }
-        { from [ "from" "," sql-interleave ] }
-        { where [ "where" "and" sql-interleave ] }
-        { group-by [ "group by" "," sql-interleave ] }
-        { having [ "having" "," sql-interleave ] }
-        { order-by [ "order by" "," sql-interleave ] }
-        { offset [ "offset" sql% sql% ] }
-        { limit [ "limit" sql% sql% ] }
-        { select [ "(select" sql% sql% ")" sql% ] }
-        { table [ sql% ] }
-        { set [ "set" "," sql-interleave ] }
-        { values [ "values(" sql% "," (sql-interleave) ")" sql% ] }
-        { count [ "count" sql-function, ] }
-        { sum [ "sum" sql-function, ] }
-        { avg [ "avg" sql-function, ] }
-        { min [ "min" sql-function, ] }
-        { max [ "max" sql-function, ] }
+        { \ columns [ "," (sql-interleave) ] }
+        { \ from [ "from" "," sql-interleave ] }
+        { \ where [ "where" "and" sql-interleave ] }
+        { \ group-by [ "group by" "," sql-interleave ] }
+        { \ having [ "having" "," sql-interleave ] }
+        { \ order-by [ "order by" "," sql-interleave ] }
+        { \ offset [ "offset" sql% sql% ] }
+        { \ limit [ "limit" sql% sql% ] }
+        { \ select [ "(select" sql% sql% ")" sql% ] }
+        { \ table [ sql% ] }
+        { \ set [ "set" "," sql-interleave ] }
+        { \ values [ break "values(" sql% "," (sql-interleave) ")" sql% ] }
+        { \ count [ "count" sql-function, ] }
+        { \ sum [ "sum" sql-function, ] }
+        { \ avg [ "avg" sql-function, ] }
+        { \ min [ "min" sql-function, ] }
+        { \ max [ "max" sql-function, ] }
         [ sql% [ sql% ] each ]
     } case ;
 

From 457644a07c99f3f228f8ced24ae5b4b2de2a8fa4 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Tue, 15 Apr 2008 22:03:40 -0500
Subject: [PATCH 010/145] Fix farkup bug

---
 extra/farkup/farkup-tests.factor   |  2 ++
 extra/xmode/catalog/catalog.factor | 10 +++++++---
 2 files changed, 9 insertions(+), 3 deletions(-)

diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor
index 8dc590449e..7176486f8e 100755
--- a/extra/farkup/farkup-tests.factor
+++ b/extra/farkup/farkup-tests.factor
@@ -61,3 +61,5 @@ IN: farkup.tests
 [ "
\"teh
" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
 [ "
" ] [ "[[lol.com]]" convert-farkup ] unit-test
 [ "
haha
" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test
+
+[ ] [ "[{}]" convert-farkup drop ] unit-test
diff --git a/extra/xmode/catalog/catalog.factor b/extra/xmode/catalog/catalog.factor
index 62f0f6ede3..22d3217ee6 100755
--- a/extra/xmode/catalog/catalog.factor
+++ b/extra/xmode/catalog/catalog.factor
@@ -36,9 +36,13 @@ TAGS>
     f \ modes set-global ;
 
 MEMO: (load-mode) ( name -- rule-sets )
-    modes at mode-file
-    "extra/xmode/modes/" prepend
-    resource-path utf8  parse-mode ;
+    modes at [
+        mode-file
+        "extra/xmode/modes/" prepend
+        resource-path utf8  parse-mode
+    ] [
+        "text" (load-mode)
+    ] if* ;
 
 SYMBOL: rule-sets
 

From f7590182ac51be1cdded983d5fedd03f27f9fbee Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Tue, 15 Apr 2008 22:03:50 -0500
Subject: [PATCH 011/145] Fix typo

---
 extra/webapps/todo/todo.css | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/extra/webapps/todo/todo.css b/extra/webapps/todo/todo.css
index f7a6cfa1a2..c2e8a7fd79 100644
--- a/extra/webapps/todo/todo.css
+++ b/extra/webapps/todo/todo.css
@@ -7,7 +7,7 @@
 	background-color: #f5f5f5;
 	padding: 5px;
 	font-size: 150%;
-	color: #000000;3
+	color: #000000;
 }
 
 .link-button {

From 361361a5560ec1ba8b68660b75ee9ee60a270045 Mon Sep 17 00:00:00 2001
From: James Cash 
Date: Fri, 11 Apr 2008 14:28:28 -0400
Subject: [PATCH 012/145] Adding deployment for Linux

---
 extra/tools/deploy/linux/authors.txt  |  1 +
 extra/tools/deploy/linux/linux.factor | 31 +++++++++++++++++++++++++++
 extra/tools/deploy/linux/summary.txt  |  1 +
 extra/tools/deploy/linux/tags.txt     |  1 +
 4 files changed, 34 insertions(+)
 create mode 100644 extra/tools/deploy/linux/authors.txt
 create mode 100644 extra/tools/deploy/linux/linux.factor
 create mode 100644 extra/tools/deploy/linux/summary.txt
 create mode 100644 extra/tools/deploy/linux/tags.txt

diff --git a/extra/tools/deploy/linux/authors.txt b/extra/tools/deploy/linux/authors.txt
new file mode 100644
index 0000000000..4b7af4aac0
--- /dev/null
+++ b/extra/tools/deploy/linux/authors.txt
@@ -0,0 +1 @@
+James Cash
diff --git a/extra/tools/deploy/linux/linux.factor b/extra/tools/deploy/linux/linux.factor
new file mode 100644
index 0000000000..fdbb67ef15
--- /dev/null
+++ b/extra/tools/deploy/linux/linux.factor
@@ -0,0 +1,31 @@
+USING: io io.files io.backend kernel namespaces sequences
+system tools.deploy.backend tools.deploy.config assocs
+hashtables prettyprint ;
+IN: tools.deploy.linux
+
+: copy-vm ( executable bundle-name -- vm )
+  prepend-path "" append
+  vm over copy-file ;
+  
+: copy-fonts ( name -- )  
+  "fonts/" resource-path swap copy-tree-into ;
+  
+: create-app-dir ( vocab bundle-name -- vm )  
+  dup copy-fonts
+  copy-vm ;
+  
+: image-name ( vocab bundle-name -- str )  
+  prepend-path ".image" append ;
+  
+: bundle-name ( -- str )  
+  deploy-name get ;
+
+M: linux deploy* ( vocab -- )
+   "." resource-path [
+       dup deploy-config [
+           [ bundle-name create-app-dir ] keep
+           [ bundle-name image-name ] keep
+           namespace make-deploy-image
+           bundle-name normalize-path [ "Binary deployed to " % % "." % ] "" make write
+     ] bind
+   ] with-directory ;  
\ No newline at end of file
diff --git a/extra/tools/deploy/linux/summary.txt b/extra/tools/deploy/linux/summary.txt
new file mode 100644
index 0000000000..4e2e8fbac4
--- /dev/null
+++ b/extra/tools/deploy/linux/summary.txt
@@ -0,0 +1 @@
+Deploying minimal stand-alone Linux binaries
diff --git a/extra/tools/deploy/linux/tags.txt b/extra/tools/deploy/linux/tags.txt
new file mode 100644
index 0000000000..ef1aab0d0e
--- /dev/null
+++ b/extra/tools/deploy/linux/tags.txt
@@ -0,0 +1 @@
+tools

From e5c880fcc2b2d2b86b468156efaf73a62d81ee01 Mon Sep 17 00:00:00 2001
From: James Cash 
Date: Fri, 11 Apr 2008 14:38:18 -0400
Subject: [PATCH 013/145] Adding information to deploy-docs regarding
 deployment on Linux

---
 extra/tools/deploy/deploy-docs.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/extra/tools/deploy/deploy-docs.factor b/extra/tools/deploy/deploy-docs.factor
index b225236249..ec9d933f8b 100755
--- a/extra/tools/deploy/deploy-docs.factor
+++ b/extra/tools/deploy/deploy-docs.factor
@@ -7,7 +7,7 @@ ARTICLE: "tools.deploy" "Application deployment"
 $nl
 "For example, we can deploy the " { $vocab-link "hello-world" } " demo which comes with Factor:"
 { $code "\"hello-ui\" deploy" }
-"On Mac OS X, this yields a program named " { $snippet "Hello world.app" } ". On Windows, it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui.exe" } ". In both cases, running the program displays a window with a message."
+"On Mac OS X, this yields a program named " { $snippet "Hello world.app" } ". On Windows, it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui.exe" } ". On Linux, it yields a directory named" { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui" } ". In all cases, running the program displays a window with a message."
 $nl
 "The deployment tool works by bootstrapping a fresh image, loading the vocabulary into this image, then applying various heuristics to strip the image down to minimal size."
 $nl

From bfbedfaac31f79515488a7aa8f45d4fcdbb73383 Mon Sep 17 00:00:00 2001
From: James Cash 
Date: Fri, 11 Apr 2008 14:38:47 -0400
Subject: [PATCH 014/145] Minor change to linux deployment, print instead of
 write

---
 extra/tools/deploy/linux/linux.factor | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

diff --git a/extra/tools/deploy/linux/linux.factor b/extra/tools/deploy/linux/linux.factor
index fdbb67ef15..05cb0cddc1 100644
--- a/extra/tools/deploy/linux/linux.factor
+++ b/extra/tools/deploy/linux/linux.factor
@@ -1,3 +1,5 @@
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
 USING: io io.files io.backend kernel namespaces sequences
 system tools.deploy.backend tools.deploy.config assocs
 hashtables prettyprint ;
@@ -26,6 +28,6 @@ M: linux deploy* ( vocab -- )
            [ bundle-name create-app-dir ] keep
            [ bundle-name image-name ] keep
            namespace make-deploy-image
-           bundle-name normalize-path [ "Binary deployed to " % % "." % ] "" make write
+           bundle-name normalize-path [ "Binary deployed to " % % "." % ] "" make print
      ] bind
    ] with-directory ;  
\ No newline at end of file

From 9d5b65ff74283ac1add60f5be9da72e99c4e14d2 Mon Sep 17 00:00:00 2001
From: James Cash 
Date: Fri, 11 Apr 2008 18:08:25 -0400
Subject: [PATCH 015/145] Fixing deploy-docs

---
 extra/tools/deploy/deploy-docs.factor | 7 ++++++-
 1 file changed, 6 insertions(+), 1 deletion(-)

diff --git a/extra/tools/deploy/deploy-docs.factor b/extra/tools/deploy/deploy-docs.factor
index ec9d933f8b..5135332955 100755
--- a/extra/tools/deploy/deploy-docs.factor
+++ b/extra/tools/deploy/deploy-docs.factor
@@ -7,7 +7,12 @@ ARTICLE: "tools.deploy" "Application deployment"
 $nl
 "For example, we can deploy the " { $vocab-link "hello-world" } " demo which comes with Factor:"
 { $code "\"hello-ui\" deploy" }
-"On Mac OS X, this yields a program named " { $snippet "Hello world.app" } ". On Windows, it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui.exe" } ". On Linux, it yields a directory named" { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui" } ". In all cases, running the program displays a window with a message."
+{ $list
+   { "On Mac OS X, this yields a program named " { $snippet "Hello world.app" } "." }
+   { "On Windows, it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui.exe" } "." }
+   { "On Linux, it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui" } "." }
+}
+"In all cases, running the program displays a window with a message."
 $nl
 "The deployment tool works by bootstrapping a fresh image, loading the vocabulary into this image, then applying various heuristics to strip the image down to minimal size."
 $nl

From 738a59ee45cd60af79520247594777b26796606a Mon Sep 17 00:00:00 2001
From: James Cash 
Date: Fri, 11 Apr 2008 22:17:59 -0400
Subject: [PATCH 016/145] Adding requisite require for linux deployment

---
 extra/tools/deploy/deploy.factor | 1 +
 1 file changed, 1 insertion(+)

diff --git a/extra/tools/deploy/deploy.factor b/extra/tools/deploy/deploy.factor
index 893b43844a..6a91fab798 100755
--- a/extra/tools/deploy/deploy.factor
+++ b/extra/tools/deploy/deploy.factor
@@ -7,3 +7,4 @@ IN: tools.deploy
 
 os macosx? [ "tools.deploy.macosx" require ] when
 os winnt? [ "tools.deploy.windows" require ] when
+os linux? [ "tools.deploy.linux" require ] when
\ No newline at end of file

From 0426ca274dea4d1b215e654a58e1d01aeecdf162 Mon Sep 17 00:00:00 2001
From: James Cash 
Date: Fri, 11 Apr 2008 22:35:58 -0400
Subject: [PATCH 017/145] Refactoring common functions out of platform-specific
 deployment

---
 extra/tools/deploy/backend/backend.factor |  9 +++++++++
 extra/tools/deploy/linux/linux.factor     | 14 ++------------
 extra/tools/deploy/macosx/macosx.factor   | 11 ++---------
 extra/tools/deploy/windows/windows.factor | 11 ++---------
 4 files changed, 15 insertions(+), 30 deletions(-)

diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor
index b838654248..ee904105be 100755
--- a/extra/tools/deploy/backend/backend.factor
+++ b/extra/tools/deploy/backend/backend.factor
@@ -105,5 +105,14 @@ DEFER: ?make-staging-image
 : make-deploy-image ( vm image vocab config -- )
     make-boot-image
     deploy-command-line run-factor ;
+    
+: copy-vm ( executable bundle-name extension -- vm )
+  [ prepend-path ] dip append vm over copy-file ;
+  
+: copy-fonts ( name dir -- )  
+  "fonts/" resource-path swap append-path copy-tree-into ;
+  
+: image-name ( vocab bundle-name -- str )  
+  prepend-path ".image" append ;
 
 HOOK: deploy* os ( vocab -- )
diff --git a/extra/tools/deploy/linux/linux.factor b/extra/tools/deploy/linux/linux.factor
index 05cb0cddc1..a995d66cd8 100644
--- a/extra/tools/deploy/linux/linux.factor
+++ b/extra/tools/deploy/linux/linux.factor
@@ -4,20 +4,10 @@ USING: io io.files io.backend kernel namespaces sequences
 system tools.deploy.backend tools.deploy.config assocs
 hashtables prettyprint ;
 IN: tools.deploy.linux
-
-: copy-vm ( executable bundle-name -- vm )
-  prepend-path "" append
-  vm over copy-file ;
-  
-: copy-fonts ( name -- )  
-  "fonts/" resource-path swap copy-tree-into ;
   
 : create-app-dir ( vocab bundle-name -- vm )  
-  dup copy-fonts
-  copy-vm ;
-  
-: image-name ( vocab bundle-name -- str )  
-  prepend-path ".image" append ;
+  dup "" copy-fonts
+  "" copy-vm ;
   
 : bundle-name ( -- str )  
   deploy-name get ;
diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor
index 3121866d94..ca710e9d28 100755
--- a/extra/tools/deploy/macosx/macosx.factor
+++ b/extra/tools/deploy/macosx/macosx.factor
@@ -14,13 +14,6 @@ IN: tools.deploy.macosx
     bundle-dir over append-path -rot
     "Contents" prepend-path append-path copy-tree ;
 
-: copy-vm ( executable bundle-name -- vm )
-    "Contents/MacOS/" append-path prepend-path vm over copy-file ;
-
-: copy-fonts ( name -- )
-    "fonts/" resource-path
-    swap "Contents/Resources/" append-path copy-tree-into ;
-
 : app-plist ( executable bundle-name -- assoc )
     [
         "6.0" "CFBundleInfoDictionaryVersion" set
@@ -40,8 +33,8 @@ IN: tools.deploy.macosx
 : create-app-dir ( vocab bundle-name -- vm )
     dup "Frameworks" copy-bundle-dir
     dup "Resources/English.lproj/MiniFactor.nib" copy-bundle-dir
-    dup copy-fonts
-    2dup create-app-plist copy-vm ;
+    dup "Contents/Resources/" copy-fonts
+    2dup create-app-plist "Contents/MacOS/" append-path "" copy-vm ;
 
 : deploy.app-image ( vocab bundle-name -- str )
     [ % "/Contents/Resources/" % % ".image" % ] "" make ;
diff --git a/extra/tools/deploy/windows/windows.factor b/extra/tools/deploy/windows/windows.factor
index 68b106663c..5fc3e92c2b 100755
--- a/extra/tools/deploy/windows/windows.factor
+++ b/extra/tools/deploy/windows/windows.factor
@@ -5,13 +5,6 @@ tools.deploy.backend tools.deploy.config assocs hashtables
 prettyprint windows.shell32 windows.user32 ;
 IN: tools.deploy.windows
 
-: copy-vm ( executable bundle-name -- vm )
-    prepend-path ".exe" append
-    vm over copy-file ;
-
-: copy-fonts ( bundle-name -- )
-    "fonts/" resource-path swap copy-tree-into ;
-
 : copy-dlls ( bundle-name -- )
     { "freetype6.dll" "zlib1.dll" "factor.dll" }
     [ resource-path ] map
@@ -19,8 +12,8 @@ IN: tools.deploy.windows
 
 : create-exe-dir ( vocab bundle-name -- vm )
     dup copy-dlls
-    dup copy-fonts
-    copy-vm ;
+    dup "" copy-fonts
+    ".exe" copy-vm ;
 
 : image-name ( vocab bundle-name -- str )
     prepend-path ".image" append ;

From c99b76b2f690c5736cba6dfbe8e7263b5851a58f Mon Sep 17 00:00:00 2001
From: James Cash 
Date: Fri, 11 Apr 2008 23:24:35 -0400
Subject: [PATCH 018/145] Got copy-fonts working properly (on Linux, at least)

---
 extra/tools/deploy/backend/backend.factor | 2 +-
 extra/tools/deploy/linux/linux.factor     | 5 ++---
 2 files changed, 3 insertions(+), 4 deletions(-)

diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor
index ee904105be..e8ca00cc8d 100755
--- a/extra/tools/deploy/backend/backend.factor
+++ b/extra/tools/deploy/backend/backend.factor
@@ -110,7 +110,7 @@ DEFER: ?make-staging-image
   [ prepend-path ] dip append vm over copy-file ;
   
 : copy-fonts ( name dir -- )  
-  "fonts/" resource-path swap append-path copy-tree-into ;
+  append-path "fonts/" resource-path swap copy-tree-into ;
   
 : image-name ( vocab bundle-name -- str )  
   prepend-path ".image" append ;
diff --git a/extra/tools/deploy/linux/linux.factor b/extra/tools/deploy/linux/linux.factor
index a995d66cd8..5f3d41c443 100644
--- a/extra/tools/deploy/linux/linux.factor
+++ b/extra/tools/deploy/linux/linux.factor
@@ -1,8 +1,7 @@
 ! Copyright (C) 2008 James Cash
 ! See http://factorcode.org/license.txt for BSD license.
-USING: io io.files io.backend kernel namespaces sequences
-system tools.deploy.backend tools.deploy.config assocs
-hashtables prettyprint ;
+USING: io io.files io.backend kernel namespaces sequences system tools.deploy.backend
+tools.deploy.config assocs hashtables prettyprint ;
 IN: tools.deploy.linux
   
 : create-app-dir ( vocab bundle-name -- vm )  

From d7ddf9ad4276f271f372b3e5c18b53f70d47fc08 Mon Sep 17 00:00:00 2001
From: James Cash 
Date: Fri, 11 Apr 2008 23:25:53 -0400
Subject: [PATCH 019/145] Factor image-name out of windows deployment

---
 extra/tools/deploy/windows/windows.factor | 3 ---
 1 file changed, 3 deletions(-)

diff --git a/extra/tools/deploy/windows/windows.factor b/extra/tools/deploy/windows/windows.factor
index 5fc3e92c2b..4f6527a4ce 100755
--- a/extra/tools/deploy/windows/windows.factor
+++ b/extra/tools/deploy/windows/windows.factor
@@ -15,9 +15,6 @@ IN: tools.deploy.windows
     dup "" copy-fonts
     ".exe" copy-vm ;
 
-: image-name ( vocab bundle-name -- str )
-    prepend-path ".image" append ;
-
 M: winnt deploy*
     "." resource-path [
         dup deploy-config [

From dca8d463beb1a6d7e9a3ce3891aead0e976cc12c Mon Sep 17 00:00:00 2001
From: James Cash 
Date: Sat, 12 Apr 2008 00:09:57 -0400
Subject: [PATCH 020/145] Minor moving stuff around in files

---
 extra/tools/deploy/backend/backend.factor | 18 +++++++++---------
 extra/tools/deploy/linux/linux.factor     |  5 +++--
 2 files changed, 12 insertions(+), 11 deletions(-)

diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor
index e8ca00cc8d..d4fbf1de78 100755
--- a/extra/tools/deploy/backend/backend.factor
+++ b/extra/tools/deploy/backend/backend.factor
@@ -8,6 +8,15 @@ debugger io.streams.c io.streams.duplex io.files io.backend
 quotations io.launcher words.private tools.deploy.config
 bootstrap.image io.encodings.utf8 accessors ;
 IN: tools.deploy.backend
+    
+: copy-vm ( executable bundle-name extension -- vm )
+  [ prepend-path ] dip append vm over copy-file ;
+  
+: copy-fonts ( name dir -- )  
+  append-path "fonts/" resource-path swap copy-tree-into ;
+  
+: image-name ( vocab bundle-name -- str )  
+  prepend-path ".image" append ;
 
 : (copy-lines) ( stream -- )
     dup stream-readln dup
@@ -105,14 +114,5 @@ DEFER: ?make-staging-image
 : make-deploy-image ( vm image vocab config -- )
     make-boot-image
     deploy-command-line run-factor ;
-    
-: copy-vm ( executable bundle-name extension -- vm )
-  [ prepend-path ] dip append vm over copy-file ;
-  
-: copy-fonts ( name dir -- )  
-  append-path "fonts/" resource-path swap copy-tree-into ;
-  
-: image-name ( vocab bundle-name -- str )  
-  prepend-path ".image" append ;
 
 HOOK: deploy* os ( vocab -- )
diff --git a/extra/tools/deploy/linux/linux.factor b/extra/tools/deploy/linux/linux.factor
index 5f3d41c443..a995d66cd8 100644
--- a/extra/tools/deploy/linux/linux.factor
+++ b/extra/tools/deploy/linux/linux.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 James Cash
 ! See http://factorcode.org/license.txt for BSD license.
-USING: io io.files io.backend kernel namespaces sequences system tools.deploy.backend
-tools.deploy.config assocs hashtables prettyprint ;
+USING: io io.files io.backend kernel namespaces sequences
+system tools.deploy.backend tools.deploy.config assocs
+hashtables prettyprint ;
 IN: tools.deploy.linux
   
 : create-app-dir ( vocab bundle-name -- vm )  

From ef29f46537443d1c2b50a2f70a1f596833ce8490 Mon Sep 17 00:00:00 2001
From: James Cash 
Date: Sun, 13 Apr 2008 00:27:59 -0400
Subject: [PATCH 021/145] Changing names for linux deployment to unix

---
 extra/tools/deploy/deploy-docs.factor                       | 2 +-
 extra/tools/deploy/deploy.factor                            | 2 +-
 extra/tools/deploy/linux/summary.txt                        | 1 -
 extra/tools/deploy/{linux => unix}/authors.txt              | 0
 extra/tools/deploy/unix/summary.txt                         | 1 +
 extra/tools/deploy/{linux => unix}/tags.txt                 | 0
 extra/tools/deploy/{linux/linux.factor => unix/unix.factor} | 0
 7 files changed, 3 insertions(+), 3 deletions(-)
 delete mode 100644 extra/tools/deploy/linux/summary.txt
 rename extra/tools/deploy/{linux => unix}/authors.txt (100%)
 create mode 100644 extra/tools/deploy/unix/summary.txt
 rename extra/tools/deploy/{linux => unix}/tags.txt (100%)
 rename extra/tools/deploy/{linux/linux.factor => unix/unix.factor} (100%)

diff --git a/extra/tools/deploy/deploy-docs.factor b/extra/tools/deploy/deploy-docs.factor
index 5135332955..eccb3982c7 100755
--- a/extra/tools/deploy/deploy-docs.factor
+++ b/extra/tools/deploy/deploy-docs.factor
@@ -10,7 +10,7 @@ $nl
 { $list
    { "On Mac OS X, this yields a program named " { $snippet "Hello world.app" } "." }
    { "On Windows, it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui.exe" } "." }
-   { "On Linux, it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui" } "." }
+   { "On Unix-like systems (Linux, BSD, Solaris, etc), it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui" } "." }
 }
 "In all cases, running the program displays a window with a message."
 $nl
diff --git a/extra/tools/deploy/deploy.factor b/extra/tools/deploy/deploy.factor
index 6a91fab798..bbeadc40cd 100755
--- a/extra/tools/deploy/deploy.factor
+++ b/extra/tools/deploy/deploy.factor
@@ -7,4 +7,4 @@ IN: tools.deploy
 
 os macosx? [ "tools.deploy.macosx" require ] when
 os winnt? [ "tools.deploy.windows" require ] when
-os linux? [ "tools.deploy.linux" require ] when
\ No newline at end of file
+os unix? [ "tools.deploy.unix" require ] when
\ No newline at end of file
diff --git a/extra/tools/deploy/linux/summary.txt b/extra/tools/deploy/linux/summary.txt
deleted file mode 100644
index 4e2e8fbac4..0000000000
--- a/extra/tools/deploy/linux/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Deploying minimal stand-alone Linux binaries
diff --git a/extra/tools/deploy/linux/authors.txt b/extra/tools/deploy/unix/authors.txt
similarity index 100%
rename from extra/tools/deploy/linux/authors.txt
rename to extra/tools/deploy/unix/authors.txt
diff --git a/extra/tools/deploy/unix/summary.txt b/extra/tools/deploy/unix/summary.txt
new file mode 100644
index 0000000000..7cd80c5e35
--- /dev/null
+++ b/extra/tools/deploy/unix/summary.txt
@@ -0,0 +1 @@
+Deploying minimal stand-alone binaries on *nix-like systems
diff --git a/extra/tools/deploy/linux/tags.txt b/extra/tools/deploy/unix/tags.txt
similarity index 100%
rename from extra/tools/deploy/linux/tags.txt
rename to extra/tools/deploy/unix/tags.txt
diff --git a/extra/tools/deploy/linux/linux.factor b/extra/tools/deploy/unix/unix.factor
similarity index 100%
rename from extra/tools/deploy/linux/linux.factor
rename to extra/tools/deploy/unix/unix.factor

From aae907d5e1a20027fa06794f06aa480b38a69646 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Tue, 15 Apr 2008 23:36:27 -0500
Subject: [PATCH 022/145] Fix problem with xml prologue showing up several
 times

---
 extra/http/http.factor                        | 18 +++----
 extra/http/server/auth/login/login.factor     | 25 ++--------
 .../server/boilerplate/boilerplate.factor     | 15 ++++--
 .../server/components/components-tests.factor | 10 ++--
 .../http/server/components/components.factor  | 35 ++++++++++++++
 extra/http/server/crud/crud.factor            | 19 ++------
 extra/http/server/forms/forms.factor          | 48 +++++++++++--------
 .../http/server/templating/chloe/chloe.factor | 18 ++++---
 .../http/server/templating/fhtml/fhtml.factor |  2 +
 .../http/server/templating/templating.factor  |  6 ++-
 extra/webapps/todo/todo.factor                |  2 +-
 11 files changed, 119 insertions(+), 79 deletions(-)

diff --git a/extra/http/http.factor b/extra/http/http.factor
index c25ae5590d..9e31855e53 100755
--- a/extra/http/http.factor
+++ b/extra/http/http.factor
@@ -394,16 +394,18 @@ body ;
     [ unparse-cookies "set-cookie" pick set-at ] when*
     write-header ;
 
-: body>quot ( body -- quot )
-    {
-        { [ dup not ] [ drop [ ] ] }
-        { [ dup string? ] [ [ write ] curry ] }
-        { [ dup callable? ] [ ] }
-        [ [ stdio get stream-copy ] curry ]
-    } cond ;
+GENERIC: write-response-body* ( body -- )
+
+M: f write-response-body* drop ;
+
+M: string write-response-body* write ;
+
+M: callable write-response-body* call ;
+
+M: object write-response-body* stdio get stream-copy ;
 
 : write-response-body ( response -- response )
-    dup body>> body>quot call ;
+    dup body>> write-response-body* ;
 
 M: response write-response ( respose -- )
     write-response-version
diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor
index 888234cc96..b0cc0c21d1 100755
--- a/extra/http/server/auth/login/login.factor
+++ b/extra/http/server/auth/login/login.factor
@@ -68,10 +68,7 @@ M: user-saver dispose
         
             [ blank-values ] >>init
 
-            [
-                "text/html" 
-                [ form edit-form ] >>body
-            ] >>display
+            [ form edit-form ] >>display
 
             [
                 blank-values
@@ -120,10 +117,7 @@ SYMBOL: user-exists?
         
             [ blank-values ] >>init
 
-            [
-                "text/html" 
-                [ form edit-form ] >>body
-            ] >>display
+            [ form edit-form ] >>display
 
             [
                 blank-values
@@ -174,10 +168,7 @@ SYMBOL: previous-page
                 dup email>> "email" set-value
             ] >>init
 
-            [
-                "text/html" 
-                [ form edit-form ] >>body
-            ] >>display
+            [ form edit-form ] >>display
 
             [
                 blank-values
@@ -262,10 +253,7 @@ SYMBOL: lost-password-from
         
             [ blank-values ] >>init
 
-            [
-                "text/html" 
-                [ form edit-form ] >>body
-            ] >>display
+            [ form edit-form ] >>display
 
             [
                 blank-values
@@ -314,10 +302,7 @@ SYMBOL: lost-password-from
                 ] H{ } make-assoc values set
             ] >>init
 
-            [
-                "text/html" 
-                [  edit-form ] >>body
-            ] >>display
+            [  edit-form ] >>display
 
             [
                 blank-values
diff --git a/extra/http/server/boilerplate/boilerplate.factor b/extra/http/server/boilerplate/boilerplate.factor
index 2bd6eee340..4e847cff70 100644
--- a/extra/http/server/boilerplate/boilerplate.factor
+++ b/extra/http/server/boilerplate/boilerplate.factor
@@ -2,6 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel namespaces boxes sequences strings
 io io.streams.string
+http
 http.server
 http.server.templating ;
 IN: http.server.boilerplate
@@ -27,6 +28,8 @@ SYMBOL: style
 : write-style ( -- )
     style get >string write ;
 
+SYMBOL: nested-template?
+
 SYMBOL: next-template
 
 : call-next-template ( -- )
@@ -39,9 +42,15 @@ M: f call-template drop call-next-template ;
         title get [  title set ] unless
         style get [ SBUF" " clone style set ] unless
 
-        swap with-string-writer next-template set
-
-        call-template
+        [
+            [
+                nested-template? on
+                write-response-body*
+            ] with-string-writer
+            next-template set
+        ]
+        [ call-template ]
+        bi*
     ] with-scope ; inline
 
 M: boilerplate call-responder
diff --git a/extra/http/server/components/components-tests.factor b/extra/http/server/components/components-tests.factor
index 29cfa1de8b..6d3a048ac4 100755
--- a/extra/http/server/components/components-tests.factor
+++ b/extra/http/server/components/components-tests.factor
@@ -1,12 +1,10 @@
 IN: http.server.components.tests
 USING: http.server.components http.server.forms
 http.server.validators namespaces tools.test kernel accessors
-tuple-syntax mirrors http.server.actions
-http.server.templating.fhtml
+tuple-syntax mirrors
+http http.server.actions http.server.templating.fhtml
 io.streams.string io.streams.null ;
 
-\ render-edit must-infer
-
 validation-failed? off
 
 [ 3 ] [ "3" "n"  validate ] unit-test
@@ -65,9 +63,9 @@ TUPLE: test-tuple text number more-text ;
             "hi" >>default
             add-field ;
 
-[ ] [   values set  view-form ] unit-test
+[ ] [   values set  view-form write-response-body drop ] unit-test
 
-[ ] [   values set  edit-form ] unit-test
+[ ] [   values set  edit-form write-response-body drop ] unit-test
 
 [ TUPLE{ test-tuple number: 123 more-text: "hi" } ] [
      from-tuple
diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor
index 3ab0bdd770..50353c6b87 100755
--- a/extra/http/server/components/components.factor
+++ b/extra/http/server/components/components.factor
@@ -7,9 +7,12 @@ continuations math ;
 IN: http.server.components
 
 ! Renderer protocol
+GENERIC: render-summary* ( value renderer -- )
 GENERIC: render-view* ( value renderer -- )
 GENERIC: render-edit* ( value id renderer -- )
 
+M: object render-summary* render-view* ;
+
 TUPLE: field type ;
 
 C:  field
@@ -235,3 +238,35 @@ TUPLE: text < string ;
 
 :  ( id -- component )
     text new-text ;
+
+! List components
+SYMBOL: +plain+
+SYMBOL: +ordered+
+SYMBOL: +unordered+
+
+TUPLE: list-renderer component type ;
+
+C:  list-renderer
+
+: render-list ( value component -- )
+    [ render-summary* ] curry each ;
+
+: render-ordered-list ( value component -- )
+    [ 
  •  render-summary* 
    •  ] curry each ;
+
+: render-unordered-list ( value component -- )
+    [ 
  •  render-summary* 
    •  ] curry each ;
+
+M: list-renderer render-view*
+    [ component>> ] [ type>> ] bi {
+        { +plain+ [ render-list ] }
+        { +ordered+ [ 
       render-ordered-list 
     ] }
+        { +unordered+ [ 
       render-unordered-list 
     ] }
+    } case ;
+
+TUPLE: list < component ;
+
+:  ( id component type -- list )
+     list swap new-component ;
+
+M: list component-string drop ;
diff --git a/extra/http/server/crud/crud.factor b/extra/http/server/crud/crud.factor
index cf9771e15f..65de881adb 100755
--- a/extra/http/server/crud/crud.factor
+++ b/extra/http/server/crud/crud.factor
@@ -15,10 +15,7 @@ IN: http.server.crud
 
         [ "id" get ctor call select-tuple from-tuple ] >>init
 
-        [
-            "text/html" 
-            [ form view-form ] >>body
-        ] >>display ;
+        [ form view-form ] >>display ;
 
 :  ( id next -- response )
     swap number>string "id" associate  ;
@@ -36,10 +33,7 @@ IN: http.server.crud
             if
         ] >>init
 
-        [
-            "text/html" 
-            [ form edit-form ] >>body
-        ] >>display
+        [ form edit-form ] >>display
 
         [
             f ctor call from-tuple
@@ -65,12 +59,9 @@ IN: http.server.crud
 ::  ( form ctor -- action )
     
         [
-            "text/html" 
-            [
-                blank-values
+            blank-values
 
-                f ctor call select-tuples "list" set-value
+            f ctor call select-tuples "list" set-value
 
-                form view-form
-            ] >>body
+            form view-form
         ] >>display ;
diff --git a/extra/http/server/forms/forms.factor b/extra/http/server/forms/forms.factor
index 2c2b673f83..1b4f7f4d37 100644
--- a/extra/http/server/forms/forms.factor
+++ b/extra/http/server/forms/forms.factor
@@ -1,4 +1,7 @@
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors assocs namespaces io.files sequences fry
+http.server
 http.server.actions
 http.server.components
 http.server.validators
@@ -17,8 +20,11 @@ M: form init V{ } clone >>components ;
 : add-field ( form component -- form )
     dup id>> pick components>> set-at ;
 
+: set-components ( form -- )
+    components>> components set ;
+
 : with-form ( form quot -- )
-    >r components>> components r> with-variable ; inline
+    [ [ set-components ] [ call ] bi* ] with-scope ; inline
 
 : set-defaults ( form -- )
     [
@@ -29,14 +35,16 @@ M: form init V{ } clone >>components ;
         ] assoc-each
     ] with-form ;
 
-: view-form ( form -- )
-    dup view-template>> '[ , call-template ] with-form ;
+:  ( form template -- response )
+    [ components>> components set ]
+    [ "text/html"  swap >>body ]
+    bi* ;
 
-: edit-form ( form -- )
-    dup edit-template>> '[ , call-template ] with-form ;
+: view-form ( form -- response )
+    dup view-template>>  ;
 
-: summary-form ( form -- )
-    dup summary-template>> '[ , call-template ] with-form ;
+: edit-form ( form -- response )
+    dup edit-template>>  ;
 
 : validate-param ( id component -- )
     [ [ params get at ] [ validate ] bi* ]
@@ -52,19 +60,19 @@ M: form init V{ } clone >>components ;
 : validate-form ( form -- )
     (validate-form) [ validation-failed ] when ;
 
-! List components
-TUPLE: list-renderer form ;
+: render-form ( value form template -- )
+    [
+        [ from-tuple ]
+        [ set-components ]
+        [ call-template ]
+        tri*
+    ] with-scope ;
 
-C:  list-renderer
+M: form render-summary*
+    dup summary-template>> render-form ;
 
-M: list-renderer render-view*
-    form>> [
-        [ >r from-tuple r> summary-form ] with-scope
-    ] curry each ;
+M: form render-view*
+    dup view-template>> render-form ;
 
-TUPLE: list < component ;
-
-:  ( id form -- list )
-    list swap  new-component ;
-
-M: list component-string drop ;
+M: form render-edit*
+    dup edit-template>> render-form ;
diff --git a/extra/http/server/templating/chloe/chloe.factor b/extra/http/server/templating/chloe/chloe.factor
index 9da153607f..06cf2936ce 100644
--- a/extra/http/server/templating/chloe/chloe.factor
+++ b/extra/http/server/templating/chloe/chloe.factor
@@ -156,13 +156,19 @@ SYMBOL: tags
     [
         V{ } clone tags set
 
-        {
-            [ xml-prolog write-prolog ]
-            [ xml-before write-chunk  ]
-            [ process-template        ]
-            [ xml-after write-chunk   ]
-        } cleave
+        nested-template? get [
+            process-template
+        ] [
+            {
+                [ xml-prolog write-prolog ]
+                [ xml-before write-chunk  ]
+                [ process-template        ]
+                [ xml-after write-chunk   ]
+            } cleave
+        ] if
     ] with-scope ;
 
 M: chloe call-template
     path>> utf8  read-xml process-chloe ;
+
+INSTANCE: chloe template
diff --git a/extra/http/server/templating/fhtml/fhtml.factor b/extra/http/server/templating/fhtml/fhtml.factor
index 237931dc34..1cba4b9b2e 100755
--- a/extra/http/server/templating/fhtml/fhtml.factor
+++ b/extra/http/server/templating/fhtml/fhtml.factor
@@ -94,3 +94,5 @@ M: fhtml call-template ( filename -- )
     [  serve-template ]
     "application/x-factor-server-page"
     pick special>> set-at ;
+
+INSTANCE: fhtml template
diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor
index 378823e9d1..f69dd9bfe0 100644
--- a/extra/http/server/templating/templating.factor
+++ b/extra/http/server/templating/templating.factor
@@ -1,9 +1,13 @@
 USING: accessors kernel fry io.encodings.utf8 io.files
-http.server ;
+http http.server ;
 IN: http.server.templating
 
+MIXIN: template
+
 GENERIC: call-template ( template -- )
 
+M: template write-response-body* call-template ;
+
 : template-convert ( template output -- )
     utf8 [ call-template ] with-file-writer ;
 
diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor
index d8d9988109..917b9bf7a7 100755
--- a/extra/webapps/todo/todo.factor
+++ b/extra/webapps/todo/todo.factor
@@ -53,7 +53,7 @@ todo "TODO"
 :  ( -- form )
     "todo-list" 
         "todo-list" todo-template >>view-template
-        "list"  
+        "list"  +plain+ 
         add-field ;
 
 TUPLE: todo-responder < dispatcher ;

From 9f46b534e91523b79e118245ae6f6af76dccb81c Mon Sep 17 00:00:00 2001
From: Eric Mertens 
Date: Tue, 15 Apr 2008 01:00:37 -0700
Subject: [PATCH 023/145] export  in random.blum-blum-shub

---
 extra/project-euler/164/164.factor                |  2 +-
 extra/random/blum-blum-shub/blum-blum-shub.factor | 11 +++++------
 2 files changed, 6 insertions(+), 7 deletions(-)

diff --git a/extra/project-euler/164/164.factor b/extra/project-euler/164/164.factor
index 67397593bd..bf1f5dcf9b 100644
--- a/extra/project-euler/164/164.factor
+++ b/extra/project-euler/164/164.factor
@@ -30,4 +30,4 @@ IN: project-euler.164
 PRIVATE>
 
 : euler164 ( -- n )
-    init-table 19 [ next-table ] times values sum ;
\ No newline at end of file
+    init-table 19 [ next-table ] times values sum ;
diff --git a/extra/random/blum-blum-shub/blum-blum-shub.factor b/extra/random/blum-blum-shub/blum-blum-shub.factor
index db8fe540e5..e60990075c 100755
--- a/extra/random/blum-blum-shub/blum-blum-shub.factor
+++ b/extra/random/blum-blum-shub/blum-blum-shub.factor
@@ -12,17 +12,16 @@ TUPLE: blum-blum-shub x n ;
 : generate-bbs-primes ( numbits -- p q )
     [ [ random-prime ] curry [ 4 mod 3 = ] generate ] dup bi ;
 
+: next-bbs-bit ( bbs -- bit )
+    [ [ x>> 2 ] [ n>> ] bi ^mod dup ] keep (>>x) 1 bitand ;
+
+PRIVATE>
+
 :  ( numbits -- blum-blum-shub )
     generate-bbs-primes *
     [ find-relative-prime ] keep
     blum-blum-shub boa ;
 
-: next-bbs-bit ( bbs -- bit )
-    [ [ x>> 2 ] [ n>> ] bi ^mod ] keep
-    over >>x drop 1 bitand ;
-
-PRIVATE>
-
 M: blum-blum-shub random-32* ( bbs -- r )
     0 32 rot
     [ next-bbs-bit swap 1 shift bitor ] curry times ;

From 8d0fdd365128dc62da34790f58eb67ee9eb52c5f Mon Sep 17 00:00:00 2001
From: Eric Mertens 
Date: Tue, 15 Apr 2008 18:04:30 -0700
Subject: [PATCH 024/145] Add project-euler solution no. 76

---
 extra/project-euler/076/076.factor | 53 ++++++++++++++++++++++++++++++
 1 file changed, 53 insertions(+)
 create mode 100644 extra/project-euler/076/076.factor

diff --git a/extra/project-euler/076/076.factor b/extra/project-euler/076/076.factor
new file mode 100644
index 0000000000..b09a2742c3
--- /dev/null
+++ b/extra/project-euler/076/076.factor
@@ -0,0 +1,53 @@
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs combinators kernel math sequences math.ranges locals ;
+IN: project-euler.076
+
+! http://projecteuler.net/index.php?section=problems&id=76
+
+! DESCRIPTION
+! -----------
+
+! How many different ways can one hundred be written as a
+! sum of at least two positive integers?
+
+! SOLUTION
+! --------
+
+! This solution uses dynamic programming and the following
+! recurence relation:
+
+! ways(0,_) = 1
+! ways(_,0) = 0
+! ways(n,i) = ways(n-i,i) + ways(n,i-1)
+
+assoc
+    1 { 0 0 } pick set-at ;
+
+: use ( n i -- n i )
+    [ - dup ] keep min ; inline
+
+: ways ( n i table -- )
+    over zero? [
+        3drop
+    ] [
+        [ [ 1-  2array ] dip at     ]
+        [ [ use 2array ] dip at +   ]
+        [ [     2array ] dip set-at ] 3tri
+    ] if ;
+
+:: each-subproblem ( n quot -- )
+    n [1,b] [ dup [1,b] quot with each ] each ; inline
+
+PRIVATE>
+
+: (euler076) ( n -- m )
+    dup init
+    [ [ ways ] curry each-subproblem ]
+    [ [ dup 2array ] dip at 1- ] 2bi ;
+
+: euler076 ( -- m )
+    100 (euler076) ;

From 2bdcba57319a12e5f5b2b619338b421420ab7776 Mon Sep 17 00:00:00 2001
From: Eric Mertens 
Date: Tue, 15 Apr 2008 23:09:23 -0700
Subject: [PATCH 025/145] Add solution for project-euler.117

---
 extra/project-euler/117/117.factor | 42 ++++++++++++++++++++++++++++++
 1 file changed, 42 insertions(+)
 create mode 100644 extra/project-euler/117/117.factor

diff --git a/extra/project-euler/117/117.factor b/extra/project-euler/117/117.factor
new file mode 100644
index 0000000000..5056560a85
--- /dev/null
+++ b/extra/project-euler/117/117.factor
@@ -0,0 +1,42 @@
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math splitting sequences ;
+
+IN: project-euler.117
+
+! http://projecteuler.net/index.php?section=problems&id=117
+
+! DESCRIPTION
+! -----------
+
+! Using a combination of black square tiles and oblong tiles chosen
+! from: red tiles measuring two units, green tiles measuring three
+! units, and blue tiles measuring four units, it is possible to tile a
+! row measuring five units in length in exactly fifteen different ways.
+
+!  How many ways can a row measuring fifty units in length be tiled?
+
+! SOLUTION
+! --------
+
+! This solution uses a simple dynamic programming approach using the
+! following recurence relation
+
+! ways(i) = 1 | i <= 0
+! ways(i) = ways(i-4) + ways(i-3) + ways(i-2) + ways(i-1)
+
+
+
+: (euler117) ( n -- m )
+    V{ 1 } clone tuck [ next ] curry times peek ;
+
+: euler117 ( -- m )
+    50 (euler117) ;

From 303f9a34506b1c2a02c43681ce861fe93f2d3c1a Mon Sep 17 00:00:00 2001
From: Eric Mertens 
Date: Wed, 16 Apr 2008 00:04:05 -0700
Subject: [PATCH 026/145] Add project-euler.116

---
 extra/project-euler/116/116.factor | 55 ++++++++++++++++++++++++++++++
 1 file changed, 55 insertions(+)
 create mode 100644 extra/project-euler/116/116.factor

diff --git a/extra/project-euler/116/116.factor b/extra/project-euler/116/116.factor
new file mode 100644
index 0000000000..d48cdf175c
--- /dev/null
+++ b/extra/project-euler/116/116.factor
@@ -0,0 +1,55 @@
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.ranges sequences sequences.lib ;
+
+IN: project-euler.116
+
+! http://projecteuler.net/index.php?section=problems&id=116
+
+! DESCRIPTION
+! -----------
+
+! A row of five black square tiles is to have a number of its tiles replaced
+! with coloured oblong tiles chosen from red (length two), green (length
+! three), or blue (length four).
+
+! If red tiles are chosen there are exactly seven ways this can be done.
+! If green tiles are chosen there are three ways.
+! And if blue tiles are chosen there are two ways.
+
+! Assuming that colours cannot be mixed there are 7 + 3 + 2 = 12 ways of
+! replacing the black tiles in a row measuring five units in length.
+
+! How many different ways can the black tiles in a row measuring fifty units in
+! length be replaced if colours cannot be mixed and at least one coloured tile
+! must be used?
+
+! SOLUTION
+! --------
+
+! This solution uses a simple dynamic programming approach using the
+! following recurence relation
+
+! ways(n,_) = 0   | n < 0
+! ways(0,_) = 1
+! ways(n,i) = ways(n-i,i) + ways(n-1,i)
+! solution(n) = ways(n,1) - 1 + ways(n,2) - 1 + ways(n,3) - 1
+
+
+
+: (euler116) ( length -- permutations )
+    3 [1,b] [ ways ] with sigma ;
+
+: euler116 ( -- permutations )
+    50 (euler116) ;

From 3483317cfb146f803b99416c28fb7cc45d1b31e1 Mon Sep 17 00:00:00 2001
From: Eric Mertens 
Date: Wed, 16 Apr 2008 02:25:38 -0700
Subject: [PATCH 027/145] Add project-euler.150

---
 extra/project-euler/150/150.factor | 46 ++++++++++++++++++++++++++++++
 1 file changed, 46 insertions(+)
 create mode 100644 extra/project-euler/150/150.factor

diff --git a/extra/project-euler/150/150.factor b/extra/project-euler/150/150.factor
new file mode 100644
index 0000000000..3bd145d53c
--- /dev/null
+++ b/extra/project-euler/150/150.factor
@@ -0,0 +1,46 @@
+USING: kernel math math.ranges math.parser sequences io locals namespaces ;
+
+IN: project-euler.150
+
+: next-t ( t -- t' )
+    615949 * 797807 + 1 20 shift rem ; inline
+
+: next-s ( t -- s )
+    1 19 shift - ; inline
+
+: generate ( -- seq )
+    0 500500 [ drop next-t dup next-s ] map nip ;
+
+: start-index ( i -- n )
+    dup 1- * 2/ ; inline
+
+: partial-sums ( seq -- seq )
+    0 [ + ] accumulate swap suffix ; inline
+
+: as-triangle ( i seq -- slices )
+    swap [1,b] [ [ start-index dup ] keep + rot  ] with map ;
+
+: sums-triangle ( -- seqs )
+    1000 generate as-triangle [ partial-sums ] map ;
+
+SYMBOL: best
+
+: check-best ( i -- )
+    best [ min ] change ; inline
+
+:: (euler150) ( m -- n )
+    [ [let | table [ sums-triangle ] |
+        0 best set
+        m [| x |
+            x 1+ [| y | 
+                1000 x - [| z |
+                    x z + table nth
+                    [ y z + 1+ swap nth ] [ y swap nth ] bi -
+                ] map partial-sums infimum check-best
+            ] each
+        ] each
+      ]
+    best get ] with-scope ;
+
+: euler150 ( -- n )
+    1000 (euler150) ;

From a25c7e1842161a8ed42407f8d3ef589a35e8546c Mon Sep 17 00:00:00 2001
From: Eric Mertens 
Date: Wed, 16 Apr 2008 10:30:03 -0700
Subject: [PATCH 028/145] Improve project-euler.150

---
 extra/project-euler/150/150.factor | 56 ++++++++++++++----------------
 1 file changed, 27 insertions(+), 29 deletions(-)

diff --git a/extra/project-euler/150/150.factor b/extra/project-euler/150/150.factor
index 3bd145d53c..5b22a1b9f6 100644
--- a/extra/project-euler/150/150.factor
+++ b/extra/project-euler/150/150.factor
@@ -1,46 +1,44 @@
-USING: kernel math math.ranges math.parser sequences io locals namespaces ;
-
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math sequences locals ;
 IN: project-euler.150
 
-: next-t ( t -- t' )
-    615949 * 797807 + 1 20 shift rem ; inline
+ ] with map ;
+: generate ( n quot -- seq )
+    [ drop ] swap compose map ; inline
 
-: sums-triangle ( -- seqs )
-    1000 generate as-triangle [ partial-sums ] map ;
+: map-infimum ( seq quot -- min )
+    [ min ] compose 0 swap reduce ; inline
 
-SYMBOL: best
 
-: check-best ( i -- )
-    best [ min ] change ; inline
+! triangle generator functions
+
+: next ( t -- new-t s )
+    615949 * 797807 + 1 20 shift mod dup 1 19 shift - ; inline
+
+: sums-triangle ( -- seq )
+    0 1000 [ 1+ [ next ] generate partial-sums ] map nip ;
+
+PRIVATE>
 
 :: (euler150) ( m -- n )
-    [ [let | table [ sums-triangle ] |
-        0 best set
+    [let | table [ sums-triangle ] |
         m [| x |
-            x 1+ [| y | 
-                1000 x - [| z |
+            x 1+ [| y |
+                m x - [| z |
                     x z + table nth
-                    [ y z + 1+ swap nth ] [ y swap nth ] bi -
-                ] map partial-sums infimum check-best
-            ] each
-        ] each
-      ]
-    best get ] with-scope ;
+                    [ y z + 1+ swap nth ]
+                    [ y        swap nth ] bi -
+                ] map partial-sums infimum
+            ] map-infimum
+        ] map-infimum
+    ] ;
 
 : euler150 ( -- n )
     1000 (euler150) ;

From 9589c5359a8a0c0109cfe6df24e978a001b16b0a Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Thu, 17 Apr 2008 03:03:00 -0500
Subject: [PATCH 029/145] Remove commented-out code

---
 core/bootstrap/stage2.factor | 4 ----
 1 file changed, 4 deletions(-)

diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor
index ca90587ea9..dfd2e4be6f 100755
--- a/core/bootstrap/stage2.factor
+++ b/core/bootstrap/stage2.factor
@@ -27,10 +27,6 @@ SYMBOL: bootstrap-time
     diff
     [ "bootstrap." prepend require ] each ;
 
-! : compile-remaining ( -- )
-!     "Compiling remaining words..." print flush
-!     vocabs [ words [ compiled? not ] subset compile ] each ;
-
 : count-words ( pred -- )
     all-words swap subset length number>string write ;
 

From 4eb4542431dc569e1488794f0d4f19a041fcd6c0 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Thu, 17 Apr 2008 03:03:22 -0500
Subject: [PATCH 030/145] Add failing unit test

---
 core/compiler/tests/templates.factor | 11 ++++++++++-
 1 file changed, 10 insertions(+), 1 deletion(-)

diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor
index 845189ce2c..14d75cdc03 100755
--- a/core/compiler/tests/templates.factor
+++ b/core/compiler/tests/templates.factor
@@ -3,7 +3,7 @@ USING: arrays compiler kernel kernel.private math
 hashtables.private math.private namespaces sequences
 sequences.private tools.test namespaces.private slots.private
 sequences.private byte-arrays alien alien.accessors layouts
-words definitions compiler.units io combinators ;
+words definitions compiler.units io combinators vectors ;
 IN: compiler.tests
 
 ! Oops!
@@ -246,3 +246,12 @@ TUPLE: my-tuple ;
     } cleave ;
 
 [ t ] [ \ float-spill-bug compiled? ] unit-test
+
+! Regression
+: dispatch-alignment-regression ( -- c )
+    { tuple vector } 3 slot { word } declare
+    dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
+
+[ t ] [ \ dispatch-alignment-regression compiled? ] unit-test
+
+[ vector ] [ dispatch-alignment-regression ] unit-test

From b2a3bfa4668163d02a093b6fef5c88f8a4720bf2 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Thu, 17 Apr 2008 03:03:33 -0500
Subject: [PATCH 031/145] Fix regexp parsing word bug

---
 extra/regexp/regexp-tests.factor | 7 +++++++
 extra/regexp/regexp.factor       | 9 +++++----
 2 files changed, 12 insertions(+), 4 deletions(-)

diff --git a/extra/regexp/regexp-tests.factor b/extra/regexp/regexp-tests.factor
index 5a6b0bdfac..e9433c6c64 100755
--- a/extra/regexp/regexp-tests.factor
+++ b/extra/regexp/regexp-tests.factor
@@ -226,3 +226,10 @@ IN: regexp-tests
 [ t ] [ "s@f" "[a-z.-]@[a-z]" f  matches? ] unit-test
 [ f ] [ "a" "[a-z.-]@[a-z]" f  matches? ] unit-test
 [ t ] [ ".o" "\\.[a-z]" f  matches? ] unit-test
+
+! Bug in parsing word
+[ t ] [
+    "a"
+    R' a'
+    matches?
+] unit-test
diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor
index 6b344ad140..d517db09fe 100755
--- a/extra/regexp/regexp.factor
+++ b/extra/regexp/regexp.factor
@@ -290,10 +290,11 @@ TUPLE: regexp source parser ignore-case? ;
     } case ;
 
 : parse-regexp ( accum end -- accum )
-    lexer get dup skip-blank [
-        [ index* dup 1+ swap ] 2keep swapd subseq swap
-    ] change-lexer-column
-    lexer get (parse-token) parse-options  parsed ;
+    lexer get dup skip-blank
+    [ [ index* dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column
+    lexer get dup still-parsing-line?
+    [ (parse-token) parse-options ] [ drop f ] if
+     parsed ;
 
 : R! CHAR: ! parse-regexp ; parsing
 : R" CHAR: " parse-regexp ; parsing

From b4ce5c93e81ad0f59c9ad55c5a84bb01af4cac39 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Thu, 17 Apr 2008 03:05:36 -0500
Subject: [PATCH 032/145] More efficient locals

---
 core/inference/backend/backend.factor         | 40 ++++----
 core/inference/known-words/known-words.factor |  8 +-
 extra/locals/backend/backend-tests.factor     | 38 ++++++++
 extra/locals/backend/backend.factor           | 37 +++++++
 extra/locals/locals-tests.factor              |  2 +
 extra/locals/locals.factor                    | 96 ++++++++-----------
 6 files changed, 142 insertions(+), 79 deletions(-)
 create mode 100644 extra/locals/backend/backend-tests.factor
 create mode 100644 extra/locals/backend/backend.factor

diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor
index cf40944d1d..e0cc1a5839 100755
--- a/core/inference/backend/backend.factor
+++ b/core/inference/backend/backend.factor
@@ -15,7 +15,7 @@ GENERIC: inline? ( word -- ? )
 M: method-body inline?
     "method-generic" word-prop inline? ;
 
-M: tuple-dispatch-engine-word inline?
+M: engine-word inline?
     "tuple-dispatch-generic" word-prop inline? ;
 
 M: word inline?
@@ -130,25 +130,27 @@ TUPLE: too-many->r ;
 
 TUPLE: too-many-r> ;
 
-: check-r> ( -- )
-    meta-r get empty?
+: check-r> ( n -- )
+    meta-r get length >
     [ \ too-many-r> inference-error ] when ;
 
-: infer->r ( -- )
-    1 ensure-values
+: infer->r ( n -- )
+    dup ensure-values
     #>r
-    1 0 pick node-inputs
-    pop-d push-r
-    0 1 pick node-outputs
-    node, ;
+    over 0 pick node-inputs
+    over [ drop pop-d ] map reverse [ push-r ] each
+    0 pick pick node-outputs
+    node,
+    drop ;
 
-: infer-r> ( -- )
-    check-r>
+: infer-r> ( n -- )
+    dup check-r>
     #r>
-    0 1 pick node-inputs
-    pop-r push-d
-    1 0 pick node-outputs
-    node, ;
+    0 pick pick node-inputs
+    over [ drop pop-r ] map reverse [ push-d ] each
+    over 0 pick node-outputs
+    node,
+    drop ;
 
 : undo-infer ( -- )
     recorded get [ f "inferred-effect" set-word-prop ] each ;
@@ -199,18 +201,18 @@ M: object constructor drop f ;
     dup infer-uncurry
     constructor [
         peek-d reify-curry
-        infer->r
+        1 infer->r
         peek-d reify-curry
-        infer-r>
+        1 infer-r>
         2 1  swap #call consume/produce
     ] when* ;
 
 : reify-curries ( n -- )
     meta-d get reverse [
         dup special? [
-            over [ infer->r ] times
+            over infer->r
             dup reify-curry
-            over [ infer-r> ] times
+            over infer-r>
         ] when 2drop
     ] 2each ;
 
diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor
index 453e2460b0..2e471420da 100755
--- a/core/inference/known-words/known-words.factor
+++ b/core/inference/known-words/known-words.factor
@@ -54,9 +54,9 @@ IN: inference.known-words
     { swap  T{ effect f 2 { 1 0         } } }
 } [ define-shuffle ] assoc-each
 
-\ >r [ infer->r ] "infer" set-word-prop
+\ >r [ 1 infer->r ] "infer" set-word-prop
 
-\ r> [ infer-r> ] "infer" set-word-prop
+\ r> [ 1 infer-r> ] "infer" set-word-prop
 
 \ declare [
     1 ensure-values
@@ -81,8 +81,8 @@ M: curried infer-call
 
 M: composed infer-call
     infer-uncurry
-    infer->r peek-d infer-call
-    terminated? get [ infer-r> peek-d infer-call ] unless ;
+    1 infer->r peek-d infer-call
+    terminated? get [ 1 infer-r> peek-d infer-call ] unless ;
 
 M: object infer-call
     \ literal-expected inference-warning ;
diff --git a/extra/locals/backend/backend-tests.factor b/extra/locals/backend/backend-tests.factor
new file mode 100644
index 0000000000..41caa87fae
--- /dev/null
+++ b/extra/locals/backend/backend-tests.factor
@@ -0,0 +1,38 @@
+IN: locals.backend.tests
+USING: tools.test locals.backend kernel arrays ;
+
+[ 3 ] [ 3 >r 1 get-local r> drop ] unit-test
+
+[ 4 ] [ 3 4 >r >r 2 get-local 2 drop-locals ] unit-test
+
+: get-local-test-1 3 >r 1 get-local r> drop ;
+
+{ 0 1 } [ get-local-test-1 ] must-infer-as
+
+[ 3 ] [ get-local-test-1 ] unit-test
+
+: get-local-test-2 3 4 >r >r 2 get-local 2 drop-locals ;
+
+{ 0 1 } [ get-local-test-2 ] must-infer-as
+
+[ 4 ] [ get-local-test-2 ] unit-test
+
+: get-local-test-3 3 4 >r >r 2 get-local r> r> 2array ;
+
+{ 0 2 } [ get-local-test-3 ] must-infer-as
+
+[ 4 { 3 4 } ] [ get-local-test-3 ] unit-test
+
+: get-local-test-4 3 4 >r >r r> r> dup swap >r swap >r r> r> 2array ;
+
+{ 0 2 } [ get-local-test-4 ] must-infer-as
+
+[ 4 { 3 4 } ] [ get-local-test-4 ] unit-test
+
+[ 1 2 ] [ 1 2 2 load-locals r> r> ] unit-test
+
+: load-locals-test-1 1 2 2 load-locals r> r> ;
+
+{ 0 2 } [ load-locals-test-1 ] must-infer-as
+
+[ 1 2 ] [ load-locals-test-1 ] unit-test
diff --git a/extra/locals/backend/backend.factor b/extra/locals/backend/backend.factor
new file mode 100644
index 0000000000..a51216b079
--- /dev/null
+++ b/extra/locals/backend/backend.factor
@@ -0,0 +1,37 @@
+USING: math kernel slots.private inference.known-words
+inference.backend sequences effects words ;
+IN: locals.backend
+
+: load-locals ( n -- )
+    dup zero? [ drop ] [ swap >r 1- load-locals ] if ;
+
+: get-local ( n -- value )
+    dup zero? [ drop dup ] [ r> swap 1- get-local swap >r ] if ;
+
+: local-value 2 slot ; inline
+
+: set-local-value 2 set-slot ; inline
+
+: drop-locals ( n -- )
+    dup zero? [ drop ] [ r> drop 1- drop-locals ] if ;
+
+\ load-locals [
+    pop-literal nip
+    [ dup reverse  infer-shuffle ]
+    [ infer->r ]
+    bi
+] "infer" set-word-prop
+
+\ get-local [
+    pop-literal nip
+    [ infer-r> ]
+    [ dup 0 prefix  infer-shuffle ]
+    [ infer->r ]
+    tri
+] "infer" set-word-prop
+
+\ drop-locals [
+    pop-literal nip
+    [ infer-r> ]
+    [ { }  infer-shuffle ] bi
+] "infer" set-word-prop
diff --git a/extra/locals/locals-tests.factor b/extra/locals/locals-tests.factor
index 4ee9b48bb7..c13be40c8f 100755
--- a/extra/locals/locals-tests.factor
+++ b/extra/locals/locals-tests.factor
@@ -82,6 +82,8 @@ IN: locals.tests
 
 0 write-test-1 "q" set
 
+{ 1 1 } "q" get must-infer-as
+
 [ 1 ] [ 1 "q" get call ] unit-test
 
 [ 2 ] [ 1 "q" get call ] unit-test
diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor
index 2b0c61cc89..be73f1db88 100755
--- a/extra/locals/locals.factor
+++ b/extra/locals/locals.factor
@@ -4,7 +4,8 @@ USING: kernel namespaces sequences sequences.private assocs math
 inference.transforms parser words quotations debugger macros
 arrays macros splitting combinators prettyprint.backend
 definitions prettyprint hashtables prettyprint.sections sets
-sequences.private effects generic compiler.units accessors ;
+sequences.private effects generic compiler.units accessors
+locals.backend ;
 IN: locals
 
 ! Inspired by
@@ -56,95 +57,80 @@ TUPLE: quote local ;
 
 C:  quote
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! read-local
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 : local-index ( obj args -- n )
     [ dup quote? [ quote-local ] when eq? ] with find drop ;
 
-: read-local ( obj args -- quot )
-    local-index 1+
-    dup [ r> ]  concat [ dup ] append
-    swap [ swap >r ]  concat append ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! localize
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: read-local-quot ( obj args -- quot )
+    local-index 1+ [ get-local ] curry ;
 
 : localize-writer ( obj args -- quot )
-  >r "local-reader" word-prop r> read-local [ 0 swap set-array-nth ] append ;
+  >r "local-reader" word-prop r>
+  read-local-quot [ set-local-value ] append ;
 
 : localize ( obj args -- quot )
     {
-        { [ over local? ]        [ read-local ] }
-        { [ over quote? ]        [ >r quote-local r> read-local ] }
-        { [ over local-word? ]   [ read-local [ call ] append ] }
-        { [ over local-reader? ] [ read-local [ 0 swap array-nth ] append ] }
+        { [ over local? ]        [ read-local-quot ] }
+        { [ over quote? ]        [ >r quote-local r> read-local-quot ] }
+        { [ over local-word? ]   [ read-local-quot [ call ] append ] }
+        { [ over local-reader? ] [ read-local-quot [ local-value ] append ] }
         { [ over local-writer? ] [ localize-writer ] }
         { [ over \ lambda eq? ]  [ 2drop [ ] ] }
         { [ t ]                  [ drop 1quotation ] }
     } cond ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! point-free
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 UNION: special local quote local-word local-reader local-writer ;
 
-: load-local ( arg -- quot ) 
-    local-reader? [ 1array >r ] [ >r ] ? ;
+: load-locals-quot ( args -- quot )
+    dup [ local-reader? ] contains? [
+         [
+            local-reader? [ 1array >r ] [ >r ] ?
+        ] map concat
+    ] [
+        length [ load-locals ] curry >quotation
+    ] if ;
 
-: load-locals ( quot args -- quot )
-    nip  [ load-local ] map concat ;
-
-: drop-locals ( args -- args quot )
-    dup length [ r> drop ]  concat ;
+: drop-locals-quot ( args -- quot )
+    length [ drop-locals ] curry ;
 
 : point-free-body ( quot args -- newquot )
     >r 1 head-slice* r> [ localize ] curry map concat ;
 
 : point-free-end ( quot args -- newquot )
     over peek special?
-    [ drop-locals >r >r peek r> localize r> append ]
-    [ drop-locals nip swap peek suffix ]
+    [ dup drop-locals-quot >r >r peek r> localize r> append ]
+    [ dup drop-locals-quot nip swap peek suffix ]
     if ;
 
 : (point-free) ( quot args -- newquot )
-    [ load-locals ] [ point-free-body ] [ point-free-end ]
+    [ nip load-locals-quot ]
+    [ point-free-body ]
+    [ point-free-end ]
     2tri 3append >quotation ;
 
 : point-free ( quot args -- newquot )
     over empty? [ drop ] [ (point-free) ] if ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! free-vars
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 UNION: lexical local local-reader local-writer local-word ;
 
-GENERIC: free-vars ( form -- vars )
+GENERIC: free-vars* ( form -- )
 
-: add-if-free ( vars object -- vars )
+: free-vars ( form -- vars )
+    [ free-vars* ] { } make prune ;
+
+: add-if-free ( object -- )
   {
-      { [ dup local-writer? ] [ "local-reader" word-prop suffix ] }
-      { [ dup lexical? ]      [ suffix ] }
-      { [ dup quote? ]        [ quote-local suffix ] }
-      { [ t ]                 [ free-vars append ] }
+      { [ dup local-writer? ] [ "local-reader" word-prop , ] }
+      { [ dup lexical? ]      [ , ] }
+      { [ dup quote? ]        [ local>> , ] }
+      { [ t ]                 [ free-vars* ] }
   } cond ;
 
-M: object free-vars drop { } ;
+M: object free-vars* drop ;
 
-M: quotation free-vars { } [ add-if-free ] reduce ;
+M: quotation free-vars* [ add-if-free ] each ;
 
-M: lambda free-vars
-    dup vars>> swap body>> free-vars diff ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! lambda-rewrite
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+M: lambda free-vars*
+    [ vars>> ] [ body>> ] bi free-vars diff % ;
 
 GENERIC: lambda-rewrite* ( obj -- )
 
@@ -172,8 +158,8 @@ M: lambda block-vars vars>> ;
 M: lambda block-body body>> ;
 
 M: lambda local-rewrite*
-    dup vars>> swap body>>
-    [ local-rewrite* \ call , ] [ ] make  , ;
+    [ vars>> ] [ body>> ] bi
+    [ [ local-rewrite* ] each ] [ ] make  , ;
 
 M: block lambda-rewrite*
     #! Turn free variables into bound variables, curry them
@@ -188,8 +174,6 @@ M: object lambda-rewrite* , ;
 
 M: object local-rewrite* , ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 : make-local ( name -- word )
     "!" ?tail [
         

From 91e516853aa161bc025412053aa9cc003ad2c562 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Thu, 17 Apr 2008 03:06:55 -0500
Subject: [PATCH 033/145] Generate branches in reverse order

---
 core/cpu/architecture/architecture.factor     |  2 +-
 core/cpu/ppc/architecture/architecture.factor |  4 ++--
 core/cpu/ppc/intrinsics/intrinsics.factor     | 20 +++++++++----------
 core/cpu/x86/32/32.factor                     |  2 +-
 core/cpu/x86/architecture/architecture.factor |  8 ++++----
 core/cpu/x86/intrinsics/intrinsics.factor     | 10 +++++-----
 core/cpu/x86/sse2/sse2.factor                 | 10 +++++-----
 core/generator/generator.factor               | 14 ++++++-------
 8 files changed, 35 insertions(+), 35 deletions(-)

diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor
index 65d1763ea8..8c9db6c7e8 100755
--- a/core/cpu/architecture/architecture.factor
+++ b/core/cpu/architecture/architecture.factor
@@ -56,7 +56,7 @@ HOOK: %call cpu ( word -- )
 HOOK: %jump-label cpu ( label -- )
 
 ! Test if vreg is 'f' or not
-HOOK: %jump-t cpu ( label -- )
+HOOK: %jump-f cpu ( label -- )
 
 HOOK: %dispatch cpu ( -- )
 
diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor
index 09ffead029..5bc6d0144d 100755
--- a/core/cpu/ppc/architecture/architecture.factor
+++ b/core/cpu/ppc/architecture/architecture.factor
@@ -106,8 +106,8 @@ M: ppc %call ( label -- ) BL ;
 
 M: ppc %jump-label ( label -- ) B ;
 
-M: ppc %jump-t ( label -- )
-    0 "flag" operand f v>operand CMPI BNE ;
+M: ppc %jump-f ( label -- )
+    0 "flag" operand f v>operand CMPI BE ;
 
 M: ppc %dispatch ( -- )
     [
diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor
index d092473960..34e9900893 100755
--- a/core/cpu/ppc/intrinsics/intrinsics.factor
+++ b/core/cpu/ppc/intrinsics/intrinsics.factor
@@ -217,11 +217,11 @@ IN: cpu.ppc.intrinsics
     2array define-if-intrinsics ;
 
 {
-    { fixnum< BLT }
-    { fixnum<= BLE }
-    { fixnum> BGT }
-    { fixnum>= BGE }
-    { eq? BEQ }
+    { fixnum< BGE }
+    { fixnum<= BGT }
+    { fixnum> BLE }
+    { fixnum>= BLT }
+    { eq? BNE }
 } [
     first2 define-fixnum-jump
 ] each
@@ -356,11 +356,11 @@ IN: cpu.ppc.intrinsics
     { { float "x" } { float "y" } } define-if-intrinsic ;
 
 {
-    { float< BLT }
-    { float<= BLE }
-    { float> BGT }
-    { float>= BGE }
-    { float= BEQ }
+    { float< BGE }
+    { float<= BGT }
+    { float> BLE }
+    { float>= BLT }
+    { float= BNE }
 } [
     first2 define-float-jump
 ] each
diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor
index cc3fceff23..f460dcfcf6 100755
--- a/core/cpu/x86/32/32.factor
+++ b/core/cpu/x86/32/32.factor
@@ -267,7 +267,7 @@ os windows? [
     EDX 26 SHR
     EDX 1 AND
     { EAX EBX ECX EDX } [ POP ] each
-    JNE
+    JE
 ] { } define-if-intrinsic
 
 "-no-sse2" cli-args member? [
diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor
index 25bb3c6e07..4c2c506e9a 100755
--- a/core/cpu/x86/architecture/architecture.factor
+++ b/core/cpu/x86/architecture/architecture.factor
@@ -47,13 +47,13 @@ M: x86 stack-frame ( n -- i )
     3 cells + 16 align cell - ;
 
 M: x86 %save-word-xt ( -- )
-    xt-reg 0 MOV rc-absolute-cell rel-this ;
+    temp-reg v>operand 0 MOV rc-absolute-cell rel-this ;
 
 : factor-area-size 4 cells ;
 
 M: x86 %prologue ( n -- )
     dup cell + PUSH
-    xt-reg PUSH
+    temp-reg v>operand PUSH
     stack-reg swap 2 cells - SUB ;
 
 M: x86 %epilogue ( n -- )
@@ -76,8 +76,8 @@ M: x86 %call ( label -- ) CALL ;
 
 M: x86 %jump-label ( label -- ) JMP ;
 
-M: x86 %jump-t ( label -- )
-    "flag" operand f v>operand CMP JNE ;
+M: x86 %jump-f ( label -- )
+    "flag" operand f v>operand CMP JE ;
 
 : code-alignment ( -- n )
     building get length dup cell align swap - ;
diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor
index 80a786c9fa..c48f33b765 100755
--- a/core/cpu/x86/intrinsics/intrinsics.factor
+++ b/core/cpu/x86/intrinsics/intrinsics.factor
@@ -212,11 +212,11 @@ IN: cpu.x86.intrinsics
     2array define-if-intrinsics ;
 
 {
-    { fixnum< JL }
-    { fixnum<= JLE }
-    { fixnum> JG }
-    { fixnum>= JGE }
-    { eq? JE }
+    { fixnum< JGE }
+    { fixnum<= JG }
+    { fixnum> JLE }
+    { fixnum>= JL }
+    { eq? JNE }
 } [
     first2 define-fixnum-jump
 ] each
diff --git a/core/cpu/x86/sse2/sse2.factor b/core/cpu/x86/sse2/sse2.factor
index 9c477b4132..fb96649753 100755
--- a/core/cpu/x86/sse2/sse2.factor
+++ b/core/cpu/x86/sse2/sse2.factor
@@ -27,11 +27,11 @@ IN: cpu.x86.sse2
     { { float "x" } { float "y" } } define-if-intrinsic ;
 
 {
-    { float< JB }
-    { float<= JBE }
-    { float> JA }
-    { float>= JAE }
-    { float= JE }
+    { float< JAE }
+    { float<= JA }
+    { float> JBE }
+    { float>= JB }
+    { float= JNE }
 } [
     first2 define-float-jump
 ] each
diff --git a/core/generator/generator.factor b/core/generator/generator.factor
index 919e89d3c8..4eb2c0fe4e 100755
--- a/core/generator/generator.factor
+++ b/core/generator/generator.factor
@@ -131,14 +131,14 @@ M: #loop generate-node
 
 : generate-if ( node label -- next )