From 457644a07c99f3f228f8ced24ae5b4b2de2a8fa4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 15 Apr 2008 22:03:40 -0500 Subject: [PATCH 01/36] 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 02/36] 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 03/36] 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 04/36] 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 05/36] 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 06/36] 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 07/36] 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 08/36] 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 09/36] 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 10/36] 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 11/36] 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 12/36] 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 13/36] 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 14/36] 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 15/36] 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 16/36] 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 17/36] 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 18/36] 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 19/36] 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 20/36] 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 21/36] 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 22/36] 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 23/36] 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 24/36] 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 )