From 0069547e908daf030ae1d493995b9fa4073f5993 Mon Sep 17 00:00:00 2001
From: Samuel Tardieu <sam@rfc1149.net>
Date: Tue, 3 Feb 2009 00:33:04 +0100
Subject: [PATCH 01/24] Fix suboptimal prime number factoring
---
basis/math/primes/factors/factors-tests.factor | 1 +
basis/math/primes/factors/factors.factor | 6 +++++-
2 files changed, 6 insertions(+), 1 deletion(-)
diff --git a/basis/math/primes/factors/factors-tests.factor b/basis/math/primes/factors/factors-tests.factor
index f247683c1c..983de51216 100644
--- a/basis/math/primes/factors/factors-tests.factor
+++ b/basis/math/primes/factors/factors-tests.factor
@@ -6,3 +6,4 @@ USING: math.primes.factors tools.test ;
{ { 999983 1000003 } } [ 999969000187000867 unique-factors ] unit-test
{ 999967000236000612 } [ 999969000187000867 totient ] unit-test
{ 0 } [ 1 totient ] unit-test
+{ { 425612003 } } [ 425612003 factors ] unit-test
diff --git a/basis/math/primes/factors/factors.factor b/basis/math/primes/factors/factors.factor
index 05d6b26010..4c36fc0a85 100644
--- a/basis/math/primes/factors/factors.factor
+++ b/basis/math/primes/factors/factors.factor
@@ -16,7 +16,11 @@ IN: math.primes.factors
PRIVATE>
: group-factors ( n -- seq )
- [ 2 [ over 1 > ] [ write-factor next-prime ] [ ] while 2drop ] { } make ;
+ [
+ 2
+ [ 2dup sq < ] [ write-factor next-prime ] [ ] until
+ drop dup 2 < [ drop ] [ 1 2array , ] if
+ ] { } make ;
: unique-factors ( n -- seq ) group-factors [ first ] map ;
From cc89943c085d02f7a590a64908627beffd2dc35e Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Thu, 5 Feb 2009 14:34:55 -0600
Subject: [PATCH 02/24] Getting rid of html.elements from most vocabs
---
basis/furnace/chloe-tags/chloe-tags.factor | 26 +++++++++++++------
basis/furnace/furnace-tests.factor | 2 +-
basis/furnace/sessions/sessions.factor | 2 +-
basis/furnace/utilities/utilities.factor | 9 +++----
basis/html/templates/chloe/chloe-docs.factor | 6 ++---
basis/html/templates/chloe/chloe-tests.factor | 2 +-
basis/html/templates/chloe/chloe.factor | 12 ++++-----
.../templates/chloe/compiler/compiler.factor | 3 +++
basis/html/templates/templates.factor | 23 +++++++++++-----
extra/webapps/user-admin/user-admin.factor | 1 -
10 files changed, 52 insertions(+), 34 deletions(-)
diff --git a/basis/furnace/chloe-tags/chloe-tags.factor b/basis/furnace/chloe-tags/chloe-tags.factor
index dd24d8dcde..be24eb5224 100644
--- a/basis/furnace/chloe-tags/chloe-tags.factor
+++ b/basis/furnace/chloe-tags/chloe-tags.factor
@@ -66,16 +66,26 @@ CHLOE: write-atom drop [ write-atom-feeds ] [code] ;
tri
[ =href a> ] [code] ;
-: a-end-tag ( tag -- )
- drop [ </a> ] [code] ;
+: process-attrs ( assoc -- newassoc )
+ [ "@" ?head [ value present ] when ] assoc-map ;
+
+: non-chloe-attrs ( tag -- )
+ attrs>> non-chloe-attrs-only [ process-attrs ] [code-with] ;
+
+: a-attrs ( tag -- )
+ [ non-chloe-attrs ]
+ [ compile-link-attrs ]
+ [ compile-a-url ] tri
+ [ swap "href" swap set-at ] [code] ;
CHLOE: a
- [
- [ a-start-tag ] [ compile-children ] [ a-end-tag ] tri
- ] compile-with-scope ;
+ [ a-attrs ]
+ [ compile-children>string ] bi
+ [ <unescaped> [XML <a><-></a> XML] swap >>attrs ]
+ [xml-code] ;
CHLOE: base
- compile-a-url [ <base =href base/> ] [code] ;
+ compile-a-url [ [XML <base href=<->/> XML] ] [xml-code] ;
: compile-hidden-form-fields ( for -- )
'[
@@ -121,13 +131,13 @@ CHLOE: form
<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
<div style="display: inline;"><button type="submit"></button></div>
</t:form>
- XML> ;
+ XML> body>> clone ;
: add-tag-attrs ( attrs tag -- )
attrs>> swap update ;
CHLOE: button
- button-tag-markup body>>
+ button-tag-markup
{
[ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ]
[ [ attrs>> non-chloe-attrs-only ] dip "button" deep-tag-named add-tag-attrs ]
diff --git a/basis/furnace/furnace-tests.factor b/basis/furnace/furnace-tests.factor
index f6e5434997..f01260c68b 100644
--- a/basis/furnace/furnace-tests.factor
+++ b/basis/furnace/furnace-tests.factor
@@ -30,7 +30,7 @@ M: base-path-check-responder call-responder*
"a/b/c" split-path main-responder get call-responder body>>
] unit-test
-[ "<input type='hidden' name='foo' value='&&&'/>" ]
+[ "<input type=\"hidden\" value=\"&&&\" name=\"foo\"/>" ]
[ [ "&&&" "foo" hidden-form-field ] with-string-writer ]
unit-test
diff --git a/basis/furnace/sessions/sessions.factor b/basis/furnace/sessions/sessions.factor
index 8b7e1ab83f..52e705c153 100644
--- a/basis/furnace/sessions/sessions.factor
+++ b/basis/furnace/sessions/sessions.factor
@@ -5,7 +5,7 @@ strings random accessors quotations hashtables sequences
continuations fry calendar combinators combinators.short-circuit
destructors alarms io.sockets db db.tuples db.types
http http.server http.server.dispatchers http.server.filters
-html.elements furnace.cache furnace.scopes furnace.utilities ;
+furnace.cache furnace.scopes furnace.utilities ;
IN: furnace.sessions
TUPLE: session < scope user-agent client ;
diff --git a/basis/furnace/utilities/utilities.factor b/basis/furnace/utilities/utilities.factor
index e09047b74a..4a9f71e8a9 100755
--- a/basis/furnace/utilities/utilities.factor
+++ b/basis/furnace/utilities/utilities.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces make assocs sequences kernel classes splitting
words vocabs.loader accessors strings combinators arrays
-continuations present fry urls html.elements http http.server
+continuations present fry urls http http.server xml.literals xml.writer
http.server.redirection http.server.remapping ;
IN: furnace.utilities
@@ -83,11 +83,8 @@ M: object modify-form drop ;
: hidden-form-field ( value name -- )
over [
- <input
- "hidden" =type
- =name
- present =value
- input/>
+ [XML <input type="hidden" value=<-> name=<->/> XML]
+ write-xml
] [ 2drop ] if ;
: nested-forms-key "__n" ;
diff --git a/basis/html/templates/chloe/chloe-docs.factor b/basis/html/templates/chloe/chloe-docs.factor
index f6408d3b59..b2259e629e 100644
--- a/basis/html/templates/chloe/chloe-docs.factor
+++ b/basis/html/templates/chloe/chloe-docs.factor
@@ -128,7 +128,7 @@ ARTICLE: "html.templates.chloe.tags.form" "Chloe link and form tags"
"<a href=\"http://mysite.org/wiki/view/Factor\""
" class=\"small-link\">"
" View"
- "s</a>"
+ "</a>"
}
} }
{ { $snippet "t:base" } { "Outputs an HTML " { $snippet "<base>" } " tag. The attributes are interpreted in the same manner as the attributes of " { $snippet "t:a" } "." } }
@@ -261,8 +261,8 @@ $nl
ARTICLE: "html.templates.chloe.extend.components.example" "An example of a custom Chloe component"
"As an example, let's develop a custom Chloe component which renders an image stored in a form value. Since the component does not require any configuration, we can define a singleton class:"
{ $code "SINGLETON: image" }
-"Now we define a method on the " { $link render* } " generic word which renders the image using " { $vocab-link "html.elements" } ":"
-{ $code "M: image render* 2drop <img =src img/> ;" }
+"Now we define a method on the " { $link render* } " generic word which renders the image using " { $vocab-link "xml.literals" } ":"
+{ $code "M: image render* 2drop [XML <img src=<-> /> XML] ;" }
"Finally, we can define a Chloe component:"
{ $code "COMPONENT: image" }
"We can use it as follows, assuming the current form has a value named " { $snippet "image" } ":"
diff --git a/basis/html/templates/chloe/chloe-tests.factor b/basis/html/templates/chloe/chloe-tests.factor
index 19b67f7018..184f57051a 100644
--- a/basis/html/templates/chloe/chloe-tests.factor
+++ b/basis/html/templates/chloe/chloe-tests.factor
@@ -135,7 +135,7 @@ TUPLE: person first-name last-name ;
[ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test
-[ "<form method='post' action='foo'><div style='display: none;'><input type='hidden' name='__n' value='a'/></div></form>" ] [
+[ "<form method='post' action='foo'><div style='display: none;'><input type=\"hidden\" value=\"a\" name=\"__n\"/></div></form>" ] [
[
"test10" test-template call-template
] run-template
diff --git a/basis/html/templates/chloe/chloe.factor b/basis/html/templates/chloe/chloe.factor
index e5b40fcfaa..99afbc31bd 100644
--- a/basis/html/templates/chloe/chloe.factor
+++ b/basis/html/templates/chloe/chloe.factor
@@ -8,7 +8,6 @@ logging continuations
xml.data xml.writer xml.literals strings
html.forms
html
-html.elements
html.components
html.templates
html.templates.chloe.compiler
@@ -28,7 +27,9 @@ CHLOE: write-title
drop
"head" tag-stack get member?
"title" tag-stack get member? not and
- [ <title> write-title </title> ] [ write-title ] ? [code] ;
+ [ get-title [XML <title><-></title> XML] ]
+ [ get-title ] ?
+ [xml-code] ;
CHLOE: style
dup "include" optional-attr [
@@ -39,10 +40,9 @@ CHLOE: style
CHLOE: write-style
drop [
- <style "text/css" =type style>
- write-style
- </style>
- ] [code] ;
+ get-style
+ [XML <style type="text/css"> <-> </style> XML]
+ ] [xml-code] ;
CHLOE: even
[ "index" value even? swap when ] process-children ;
diff --git a/basis/html/templates/chloe/compiler/compiler.factor b/basis/html/templates/chloe/compiler/compiler.factor
index 7180e8cdbc..394b5ef359 100644
--- a/basis/html/templates/chloe/compiler/compiler.factor
+++ b/basis/html/templates/chloe/compiler/compiler.factor
@@ -42,6 +42,9 @@ DEFER: compile-element
: [code-with] ( obj quot -- )
reset-buffer [ , ] [ % ] bi* ;
+: [xml-code] ( quot -- )
+ [ write-xml ] compose [code] ;
+
: expand-attr ( value -- )
[ value present write ] [code-with] ;
diff --git a/basis/html/templates/templates.factor b/basis/html/templates/templates.factor
index efaf8d6a62..c0fec8d1b6 100644
--- a/basis/html/templates/templates.factor
+++ b/basis/html/templates/templates.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel fry io io.encodings.utf8 io.files
debugger prettyprint continuations namespaces boxes sequences
-arrays strings html io.streams.string
+arrays strings html io.streams.string assocs
quotations xml.data xml.writer xml.literals ;
IN: html.templates
@@ -34,8 +34,11 @@ SYMBOL: title
: set-title ( string -- )
title get >box ;
+: get-title ( -- string )
+ title get value>> ;
+
: write-title ( -- )
- title get value>> write ;
+ get-title write ;
SYMBOL: style
@@ -43,24 +46,30 @@ SYMBOL: style
"\n" style get push-all
style get push-all ;
+: get-style ( -- string )
+ style get >string ;
+
: write-style ( -- )
- style get >string write ;
+ get-style write ;
SYMBOL: atom-feeds
: add-atom-feed ( title url -- )
2array atom-feeds get push ;
-: write-atom-feeds ( -- )
+: get-atom-feeds ( -- xml )
atom-feeds get [
- first2 [XML
+ [XML
<link
rel="alternate"
type="application/atom+xml"
title=<->
href=<->/>
- XML] write-xml
- ] each ;
+ XML]
+ ] { } assoc>map ;
+
+: write-atom-feeds ( -- )
+ get-atom-feeds write-xml ;
SYMBOL: nested-template?
diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor
index 9d4e348596..c0cd601af5 100644
--- a/extra/webapps/user-admin/user-admin.factor
+++ b/extra/webapps/user-admin/user-admin.factor
@@ -3,7 +3,6 @@
USING: kernel sequences accessors namespaces combinators words
assocs db.tuples arrays splitting strings validators urls
html.forms
-html.elements
html.components
furnace
furnace.boilerplate
From 28e644209c1c82c5e59cd49bf0680999f45c79bc Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Fri, 6 Feb 2009 00:42:46 -0600
Subject: [PATCH 03/24] Unicode.case supports lithuanian properly (hopefully)
---
basis/unicode/case/case-tests.factor | 16 +++++++++++++--
basis/unicode/case/case.factor | 30 ++++++++++++++++++----------
2 files changed, 34 insertions(+), 12 deletions(-)
diff --git a/basis/unicode/case/case-tests.factor b/basis/unicode/case/case-tests.factor
index 6e26a36a19..52a8d9755e 100644
--- a/basis/unicode/case/case-tests.factor
+++ b/basis/unicode/case/case-tests.factor
@@ -1,4 +1,7 @@
-USING: unicode.case tools.test namespaces ;
+! Copyright (C) 2008, 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: unicode.case unicode.case.private tools.test namespaces strings unicode.normalize ;
+IN: unicode.case.tests
\ >upper must-infer
\ >lower must-infer
@@ -9,12 +12,21 @@ USING: unicode.case tools.test namespaces ;
[ "\u0003C3a\u0003C2 \u0003C3\u0003C2 \u0003C3a\u0003C2" ] [ "\u0003A3A\u0003A3 \u0003A3\u0003A3 \u0003A3A\u0003A3" >lower ] unit-test
[ t ] [ "hello how are you?" lower? ] unit-test
[
+ [ f ] [ i-dot? ] unit-test
+ [ f ] [ lt? ] unit-test
"tr" locale set
+ [ t ] [ i-dot? ] unit-test
+ [ f ] [ lt? ] unit-test
[ "i\u000131i \u000131jj" ] [ "i\u000131I\u000307 IJj" >lower ] unit-test
[ "I\u000307\u000131i Ijj" ] [ "i\u000131I\u000307 IJj" >title ] unit-test
[ "I\u000307II\u000307 IJJ" ] [ "i\u000131I\u000307 IJj" >upper ] unit-test
"lt" locale set
- ! Lithuanian casing tests
+ [ f ] [ i-dot? ] unit-test
+ [ t ] [ lt? ] unit-test
+ [ "i\u000307\u000300" ] [ HEX: CC 1string nfd >lower ] unit-test
+ [ "\u00012f\u000307" ] [ HEX: 12E 1string nfd >lower nfc ] unit-test
+ [ "I\u000300" ] [ "i\u000307\u000300" >upper ] unit-test
+! [ "I\u000300" ] [ "i\u000307\u000300" >title ] unit-test
] with-scope
[ t ] [ "asdf" lower? ] unit-test
diff --git a/basis/unicode/case/case.factor b/basis/unicode/case/case.factor
index 65fab0ac38..3ac98cd57f 100644
--- a/basis/unicode/case/case.factor
+++ b/basis/unicode/case/case.factor
@@ -1,8 +1,8 @@
-! Copyright (C) 2008 Daniel Ehrenberg.
+! Copyright (C) 2008, 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: unicode.data sequences namespaces
sbufs make unicode.syntax unicode.normalize math hints
-unicode.categories combinators unicode.syntax assocs
+unicode.categories combinators unicode.syntax assocs combinators.short-circuit
strings splitting kernel accessors unicode.breaks fry locals ;
QUALIFIED: ascii
IN: unicode.case
@@ -26,6 +26,9 @@ SYMBOL: locale ! Just casing locale, or overall?
: i-dot? ( -- ? )
locale get { "tr" "az" } member? ;
+: lt? ( -- ? )
+ locale get "lt" = ;
+
: lithuanian? ( -- ? ) locale get "lt" = ;
: dot-over ( -- ch ) HEX: 307 ;
@@ -37,18 +40,21 @@ SYMBOL: locale ! Just casing locale, or overall?
: mark-above? ( ch -- ? )
combining-class 230 = ;
-: with-rest ( seq quot: ( seq -- seq ) -- seq )
- [ unclip ] dip swap slip prefix ; inline
+:: with-rest ( seq quot: ( seq -- seq ) -- seq )
+ seq unclip quot dip prefix ; inline
: add-dots ( seq -- seq )
- [ [ "" ] [
- dup first mark-above?
- [ CHAR: combining-dot-above prefix ] when
+ [ [ { } ] [
+ [
+ dup first
+ { [ mark-above? ] [ CHAR: combining-ogonek = ] } 1||
+ [ CHAR: combining-dot-above prefix ] when
+ ] map
] if-empty ] with-rest ; inline
: lithuanian>lower ( string -- lower )
- "i" split add-dots "i" join
- "j" split add-dots "i" join ; inline
+ "I" split add-dots "I" join
+ "J" split add-dots "J" join ; inline
: turk>upper ( string -- upper-i )
"i" "I\u000307" replace ; inline
@@ -88,13 +94,16 @@ SYMBOL: locale ! Just casing locale, or overall?
PRIVATE>
: >lower ( string -- lower )
- i-dot? [ turk>lower ] when final-sigma
+ i-dot? [ turk>lower ] when
+ lt? [ lithuanian>lower ] when
+ final-sigma
[ lower>> ] [ ch>lower ] map-case ;
HINTS: >lower string ;
: >upper ( string -- upper )
i-dot? [ turk>upper ] when
+ lt? [ lithuanian>upper ] when
[ upper>> ] [ ch>upper ] map-case ;
HINTS: >upper string ;
@@ -103,6 +112,7 @@ HINTS: >upper string ;
: (>title) ( string -- title )
i-dot? [ turk>upper ] when
+ lt? [ lithuanian>upper ] when
[ title>> ] [ ch>title ] map-case ; inline
: title-word ( string -- title )
From 33b513fb0538ce9946d861f2b853095a54b0cef0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 6 Feb 2009 10:16:51 -0600
Subject: [PATCH 04/24] byte-length on f outputs 0
---
basis/alien/c-types/c-types.factor | 2 ++
1 file changed, 2 insertions(+)
diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor
index ff9d4cefc4..cf5daa1562 100644
--- a/basis/alien/c-types/c-types.factor
+++ b/basis/alien/c-types/c-types.factor
@@ -178,6 +178,8 @@ GENERIC: byte-length ( seq -- n ) flushable
M: byte-array byte-length length ;
+M: f byte-length drop 0 ;
+
: c-getter ( name -- quot )
c-type-getter [
[ "Cannot read struct fields with this type" throw ]
From 79bb003e6dce8d346032de749f26c791e5be56a8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 6 Feb 2009 10:17:20 -0600
Subject: [PATCH 05/24] io.sockets.secure.openssl: Don't allocate empty
password string. Fixes test failures introduced by >c-ptr change
---
basis/io/sockets/secure/openssl/openssl.factor | 12 +++++++-----
1 file changed, 7 insertions(+), 5 deletions(-)
diff --git a/basis/io/sockets/secure/openssl/openssl.factor b/basis/io/sockets/secure/openssl/openssl.factor
index 0326969e4f..f78f61ef3b 100644
--- a/basis/io/sockets/secure/openssl/openssl.factor
+++ b/basis/io/sockets/secure/openssl/openssl.factor
@@ -46,11 +46,13 @@ TUPLE: openssl-context < secure-context aliens sessions ;
[ push ] [ drop ] 2bi ;
: set-default-password ( ctx -- )
- [ handle>> password-callback SSL_CTX_set_default_passwd_cb ]
- [
- [ handle>> ] [ default-pasword ] bi
- SSL_CTX_set_default_passwd_cb_userdata
- ] bi ;
+ dup config>> password>> [
+ [ handle>> password-callback SSL_CTX_set_default_passwd_cb ]
+ [
+ [ handle>> ] [ default-pasword ] bi
+ SSL_CTX_set_default_passwd_cb_userdata
+ ] bi
+ ] [ drop ] if ;
: use-private-key-file ( ctx -- )
dup config>> key-file>> [
From 53758074a29aa3b5c85ede92199705ee11db2433 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 6 Feb 2009 10:21:55 -0600
Subject: [PATCH 06/24] stack-checker: do constant folding for curry and
compose with constant inputs at compile time. Allows macros to expand in more
cases, fixing the fry caveat found by Doug
---
.../known-words/known-words.factor | 53 ++++++++-----------
basis/stack-checker/stack-checker-docs.factor | 8 ---
.../stack-checker/stack-checker-tests.factor | 5 ++
.../transforms/transforms-docs.factor | 13 +++--
.../transforms/transforms-tests.factor | 9 ++++
.../transforms/transforms.factor | 4 +-
basis/stack-checker/values/values.factor | 30 +++++++++--
7 files changed, 73 insertions(+), 49 deletions(-)
diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index 7cdce301b5..56aebb20e7 100644
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -89,44 +89,37 @@ M: composed infer-call*
M: object infer-call*
\ literal-expected inference-warning ;
-: infer-slip ( -- )
- 1 infer->r infer-call 1 infer-r> ;
+: infer-nslip ( n -- )
+ [ infer->r infer-call ] [ infer-r> ] bi ;
-: infer-2slip ( -- )
- 2 infer->r infer-call 2 infer-r> ;
+: infer-slip ( -- ) 1 infer-nslip ;
-: infer-3slip ( -- )
- 3 infer->r infer-call 3 infer-r> ;
+: infer-2slip ( -- ) 2 infer-nslip ;
-: infer-dip ( -- )
- literals get
- [ \ dip def>> infer-quot-here ]
- [ pop 1 infer->r infer-quot-here 1 infer-r> ]
+: infer-3slip ( -- ) 3 infer-nslip ;
+
+: infer-ndip ( word n -- )
+ [ literals get ] 2dip
+ [ '[ _ def>> infer-quot-here ] ]
+ [ '[ _ [ pop ] dip [ infer->r infer-quot-here ] [ infer-r> ] bi ] ] bi*
if-empty ;
-: infer-2dip ( -- )
- literals get
- [ \ 2dip def>> infer-quot-here ]
- [ pop 2 infer->r infer-quot-here 2 infer-r> ]
- if-empty ;
+: infer-dip ( -- ) \ dip 1 infer-ndip ;
-: infer-3dip ( -- )
- literals get
- [ \ 3dip def>> infer-quot-here ]
- [ pop 3 infer->r infer-quot-here 3 infer-r> ]
- if-empty ;
+: infer-2dip ( -- ) \ 2dip 2 infer-ndip ;
-: infer-curry ( -- )
- 2 consume-d
- dup first2 <curried> make-known
- [ push-d ] [ 1array ] bi
- \ curry #call, ;
+: infer-3dip ( -- ) \ 3dip 3 infer-ndip ;
-: infer-compose ( -- )
- 2 consume-d
- dup first2 <composed> make-known
- [ push-d ] [ 1array ] bi
- \ compose #call, ;
+: infer-builder ( quot word -- )
+ [
+ [ 2 consume-d ] dip
+ [ dup first2 ] dip call make-known
+ [ push-d ] [ 1array ] bi
+ ] dip #call, ; inline
+
+: infer-curry ( -- ) [ <curried> ] \ curry infer-builder ;
+
+: infer-compose ( -- ) [ <composed> ] \ compose infer-builder ;
: infer-execute ( -- )
pop-literal nip
diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor
index 5b67cd9adc..5926f08d8c 100644
--- a/basis/stack-checker/stack-checker-docs.factor
+++ b/basis/stack-checker/stack-checker-docs.factor
@@ -80,13 +80,6 @@ $nl
"[ [ 5 ] t foo ] infer."
} ;
-ARTICLE: "compiler-transforms" "Compiler transforms"
-"Compiler transforms can be used to allow words to compile which would otherwise not have a stack effect, and to expand combinators into more efficient code at compile time."
-{ $subsection define-transform }
-"An example is the " { $link cond } " word. If the association list of quotations it is given is literal, the entire form is expanded into a series of nested calls to " { $link if } "."
-$nl
-"The " { $vocab-link "macros" } " vocabulary defines some nice syntax sugar which makes compiler transforms easier to work with." ;
-
ARTICLE: "inference" "Stack effect inference"
"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the optimizing compiler to build the high-level SSA representation on which optimizations can be performed. Only words for which a stack effect can be inferred will compile with the optimizing compiler; all other words will be compiled with the non-optimizing compiler (see " { $link "compiler" } ")."
$nl
@@ -103,7 +96,6 @@ $nl
{ $subsection "inference-recursive-combinators" }
{ $subsection "inference-branches" }
{ $subsection "inference-errors" }
-{ $subsection "compiler-transforms" }
{ $see-also "effects" } ;
ABOUT: "inference"
diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor
index 4d7295042c..bc6eb9f092 100644
--- a/basis/stack-checker/stack-checker-tests.factor
+++ b/basis/stack-checker/stack-checker-tests.factor
@@ -577,3 +577,8 @@ DEFER: eee'
[ bogus-error ] must-infer
[ [ clear ] infer. ] [ inference-error? ] must-fail-with
+
+: debugging-curry-folding ( quot -- )
+ [ debugging-curry-folding ] curry call ; inline recursive
+
+[ [ ] debugging-curry-folding ] must-infer
\ No newline at end of file
diff --git a/basis/stack-checker/transforms/transforms-docs.factor b/basis/stack-checker/transforms/transforms-docs.factor
index a178669595..de0edc4528 100644
--- a/basis/stack-checker/transforms/transforms-docs.factor
+++ b/basis/stack-checker/transforms/transforms-docs.factor
@@ -3,12 +3,11 @@ USING: help.markup help.syntax combinators words kernel ;
HELP: define-transform
{ $values { "word" word } { "quot" "a quotation taking " { $snippet "n" } " inputs from the stack and producing another quotation as output" } { "n" "a non-negative integer" } }
-{ $description "Defines a compiler transform for the optimizing compiler. When a call to " { $snippet "word" } " is being compiled, the compiler ensures that the top " { $snippet "n" } " stack values are literal; if they are not, compilation fails. The literal values are passed to the quotation, which is expected to produce a new quotation. The call to the word is then replaced by this quotation." }
-{ $examples "Here is a word which pops " { $snippet "n" } " values from the stack:"
-{ $code ": ndrop ( n -- ) [ drop ] times ;" }
-"This word is inefficient; it does not have a static stack effect. This means that words calling " { $snippet "ndrop" } " cannot be compiled by the optimizing compiler, and additionally, a call to this word will always involve a loop with arithmetic, even if the value of " { $snippet "n" } " is known at compile time. A compiler transform can fix this:"
-{ $code "\\ ndrop [ \\ drop <repetition> >quotation ] 1 define-transform" }
-"Now, a call like " { $snippet "4 ndrop" } " is replaced with " { $snippet "drop drop drop drop" } " at compile time; the optimizer then ensures that this compiles as a single machine instruction, which is a lot cheaper than an actual call to " { $snippet "ndrop" } "."
+{ $description "Defines a compiler transform for the optimizing compiler."
+ "When a call to " { $snippet "word" } " is being compiled, the compiler first checks that the top " { $snippet "n" } " stack values are literal, and if so, calls the quotation with those inputs at compile time. The quotation can output a new quotation, or " { $link f } "."
$nl
-"The " { $link cond } " word compiles to efficient code because it is transformed using " { $link cond>quot } ":"
+"If the quotation outputs " { $link f } ", or if not all inputs are literal, a call to the word is compiled as usual, or compilation fails if the word does not have a static stack effect."
+$nl
+"Otherwise, if the transform output a new quotation, the quotation replaces the word's call site." }
+{ $examples "The " { $link cond } " word compiles to efficient code because it is transformed using " { $link cond>quot } ":"
{ $code "\\ cond [ cond>quot ] 1 define-transform" } } ;
diff --git a/basis/stack-checker/transforms/transforms-tests.factor b/basis/stack-checker/transforms/transforms-tests.factor
index 2e2dccd6c4..fe580084c0 100644
--- a/basis/stack-checker/transforms/transforms-tests.factor
+++ b/basis/stack-checker/transforms/transforms-tests.factor
@@ -57,3 +57,12 @@ DEFER: smart-combo ( quot -- )
[ [ "a" "b" "c" ] very-smart-combo ] must-infer
[ [ [ "a" "b" ] very-smart-combo "c" ] very-smart-combo ] must-infer
+
+! Caveat found by Doug
+DEFER: curry-folding-test ( quot -- )
+
+\ curry-folding-test [ length \ drop <repetition> >quotation ] 1 define-transform
+
+{ 3 0 } [ [ 1 2 3 ] curry-folding-test ] must-infer-as
+{ 3 0 } [ 1 [ 2 3 ] curry curry-folding-test ] must-infer-as
+{ 3 0 } [ [ 1 2 ] 3 [ ] curry compose curry-folding-test ] must-infer-as
\ No newline at end of file
diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor
index e5c2f05d72..a2f616480a 100755
--- a/basis/stack-checker/transforms/transforms.factor
+++ b/basis/stack-checker/transforms/transforms.factor
@@ -24,8 +24,10 @@ IN: stack-checker.transforms
rstate infer-quot
] [ word give-up-transform ] if* ;
+: literals? ( values -- ? ) [ literal-value? ] all? ;
+
: (apply-transform) ( word quot n -- )
- ensure-d dup [ known literal? ] all? [
+ ensure-d dup literals? [
dup empty? [ dup recursive-state get ] [
[ ]
[ [ literal value>> ] map ]
diff --git a/basis/stack-checker/values/values.factor b/basis/stack-checker/values/values.factor
index 97aa774e55..19db441381 100644
--- a/basis/stack-checker/values/values.factor
+++ b/basis/stack-checker/values/values.factor
@@ -26,27 +26,51 @@ SYMBOL: known-values
: copy-values ( values -- values' )
[ copy-value ] map ;
+GENERIC: (literal-value?) ( value -- ? )
+
+M: object (literal-value?) drop f ;
+
+GENERIC: (literal) ( value -- literal )
+
! Literal value
TUPLE: literal < identity-tuple value recursion hashcode ;
+: literal ( value -- literal ) known (literal) ;
+
+: literal-value? ( value -- ? ) known (literal-value?) ;
+
M: literal hashcode* nip hashcode>> ;
: <literal> ( obj -- value )
recursive-state get over hashcode \ literal boa ;
-GENERIC: (literal) ( value -- literal )
+M: literal (literal-value?) drop t ;
M: literal (literal) ;
-: literal ( value -- literal )
- known (literal) ;
+: curried/composed-literal ( input1 input2 quot -- literal )
+ [ [ literal ] bi@ ] dip
+ [ [ [ value>> ] bi@ ] dip call ] [ drop nip recursion>> ] 3bi
+ over hashcode \ literal boa ; inline
! Result of curry
TUPLE: curried obj quot ;
C: <curried> curried
+: >curried< ( curried -- obj quot )
+ [ obj>> ] [ quot>> ] bi ; inline
+
+M: curried (literal-value?) >curried< [ literal-value? ] both? ;
+M: curried (literal) >curried< [ curry ] curried/composed-literal ;
+
! Result of compose
TUPLE: composed quot1 quot2 ;
C: <composed> composed
+
+: >composed< ( composed -- quot1 quot2 )
+ [ quot1>> ] [ quot2>> ] bi ; inline
+
+M: composed (literal-value?) >composed< [ literal-value? ] both? ;
+M: composed (literal) >composed< [ compose ] curried/composed-literal ;
\ No newline at end of file
From d1486589efc44be2c58277597dc37e84f70c4017 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 6 Feb 2009 10:22:09 -0600
Subject: [PATCH 07/24] Improving macro docs
---
basis/macros/macros-docs.factor | 45 ++++++++++++++++++++++++++-------
basis/macros/macros.factor | 4 +++
core/kernel/kernel-docs.factor | 17 +++++++------
3 files changed, 49 insertions(+), 17 deletions(-)
diff --git a/basis/macros/macros-docs.factor b/basis/macros/macros-docs.factor
index 704cae459a..acd2c3383f 100644
--- a/basis/macros/macros-docs.factor
+++ b/basis/macros/macros-docs.factor
@@ -1,27 +1,54 @@
-USING: help.markup help.syntax quotations kernel ;
+USING: help.markup help.syntax quotations kernel
+stack-checker.transforms sequences ;
IN: macros
HELP: MACRO:
{ $syntax "MACRO: word ( inputs... -- ) definition... ;" }
-{ $description "Defines a compile-time code transformation. If all inputs to the word are literal and the word calling the macro has a static stack effect, then the macro body is invoked at compile-time to produce a quotation; this quotation is then spliced into the compiled code. If the inputs are not literal, or if the word is invoked from a word which does not have a static stack effect, the macro body will execute every time and the result will be passed to " { $link call } "."
-$nl
-"The stack effect declaration must be present because it tells the compiler how many literal inputs to expect."
-}
+{ $description "Defines a code transformation. The definition must have stack effect " { $snippet "( inputs... -- quot )" } "." }
{ $notes
- "Semantically, the following two definitions are equivalent:"
+ "A call of a macro inside a word definition is replaced with the quotation expansion at compile-time if precisely the following conditions hold:"
+ { $list
+ { "All inputs to the macro call are literal" }
+ { "The word calling the macro has a static stack effect" }
+ { "The expansion quotation produced by the macro has a static stack effect" }
+ }
+ "If any of these conditions fail to hold, the macro will still work, but expansion will be performed at run-time."
+ $nl
+ "Other than possible compile-time expansion, the following two definition styles are equivalent:"
{ $code "MACRO: foo ... ;" }
{ $code ": foo ... call ;" }
- "However, the compiler folds in macro definitions at compile-time where possible; if the macro body performs an expensive calculation, it can lead to a performance boost."
+ "Conceptually, macros allow computation to be moved from run-time to compile-time, splicing the result of this computation into the generated quotation."
+}
+{ $examples
+ "A macro that calls a quotation but preserves any values it consumes off the stack:"
+ { $code
+ "USING: fry generalizations ;"
+ "MACRO: preserving ( quot -- )"
+ " [ infer in>> length ] keep '[ _ ndup @ ] ;"
+ }
+ "Using this macro, we can define a variant of " { $link if } " which takes a predicate quotation instead of a boolean; any values consumed by the predicate quotation are restored immediately after:"
+ { $code
+ ": ifte ( pred true false -- ) [ preserving ] 2dip if ; inline"
+ }
+ "Note that " { $snippet "ifte" } " is an ordinary word, and it passes one of its inputs to the macro. If another word calls " { $snippet "ifte" } " with all three input quotations literal, then " { $snippet "ifte" } " will be inlined and " { $snippet "preserving" } " will expand at compile-time, and the generated machine code will be exactly the same as if the inputs consumed by the predicate were duplicated by hand."
+ $nl
+ "The " { $snippet "ifte" } " combinator presented here has similar semantics to the " { $snippet "ifte" } " combinator of the Joy programming language."
} ;
HELP: macro
{ $class-description "Class of words defined with " { $link POSTPONE: MACRO: } "." } ;
ARTICLE: "macros" "Macros"
-"The " { $vocab-link "macros" } " vocabulary implements macros in the Lisp sense; compile-time code transformers and generators. Macros can be used to calculate lookup tables and generate code at compile time, which can improve performance, the level of abstraction and simplify code."
+"The " { $vocab-link "macros" } " vocabulary implements " { $emphasis "macros" } ", which are code transformations that may run at compile-time under the right circumstances."
+$nl
+"Macros can be used to give static stack effects to combinators that otherwise would not have static stack effects. Macros can be used to calculate lookup tables and generate code at compile time, which can improve performance, the level of abstraction and simplify code."
+$nl
+"Factor macros are similar to Lisp macros; they are not like C preprocessor macros."
$nl
"Defining new macros:"
{ $subsection POSTPONE: MACRO: }
-"Macros are really just a very thin layer of syntax sugar over " { $link "compiler-transforms" } "." ;
+"A slightly lower-level facility, " { $emphasis "compiler transforms" } ", allows an ordinary word definition to co-exist with a version that performs compile-time expansion."
+{ $subsection define-transform }
+"An example is the " { $link member? } " word. If the input sequence is a literal, the compile transform kicks in and converts the " { $link member? } " call into a series of conditionals. Otherwise, if the input sequence is not literal, a call to the definition of " { $link member? } " is generated." ;
ABOUT: "macros"
diff --git a/basis/macros/macros.factor b/basis/macros/macros.factor
index 1481e6eea5..4fba7efba3 100644
--- a/basis/macros/macros.factor
+++ b/basis/macros/macros.factor
@@ -4,9 +4,13 @@ USING: parser kernel sequences words effects combinators assocs
definitions quotations namespaces memoize accessors ;
IN: macros
+<PRIVATE
+
: real-macro-effect ( word -- effect' )
"declared-effect" word-prop in>> 1 <effect> ;
+PRIVATE>
+
: define-macro ( word definition -- )
[ "macro" set-word-prop ]
[ over real-macro-effect memoize-quot [ call ] append define ]
diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor
index d85a51edff..71183093ee 100644
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@@ -949,6 +949,13 @@ ARTICLE: "assertions" "Assertions"
{ $subsection assert }
{ $subsection assert= } ;
+ARTICLE: "dataflow-combinators" "Data flow combinators"
+"Data flow combinators pass values between quotations:"
+{ $subsection "slip-keep-combinators" }
+{ $subsection "cleave-combinators" }
+{ $subsection "spread-combinators" }
+{ $subsection "apply-combinators" } ;
+
ARTICLE: "dataflow" "Data and control flow"
{ $subsection "evaluator" }
{ $subsection "words" }
@@ -956,16 +963,9 @@ ARTICLE: "dataflow" "Data and control flow"
{ $subsection "booleans" }
{ $subsection "shuffle-words" }
"A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input."
-$nl
-"Data flow combinators:"
-{ $subsection "slip-keep-combinators" }
-{ $subsection "cleave-combinators" }
-{ $subsection "spread-combinators" }
-{ $subsection "apply-combinators" }
-"Control flow combinators:"
+{ $subsection "dataflow-combinators" }
{ $subsection "conditionals" }
{ $subsection "looping-combinators" }
-"Additional combinators:"
{ $subsection "compositional-combinators" }
{ $subsection "combinators" }
"More combinators are defined for working on data structures, such as " { $link "sequences-combinators" } " and " { $link "assocs-combinators" } "."
@@ -973,6 +973,7 @@ $nl
"Advanced topics:"
{ $subsection "assertions" }
{ $subsection "implementing-combinators" }
+{ $subsection "macros" }
{ $subsection "errors" }
{ $subsection "continuations" } ;
From 31f976e0e909aff88f122cde1de0e7bb381969fa Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 6 Feb 2009 10:22:22 -0600
Subject: [PATCH 08/24] pack: cleanup, write macros in more intuitive style
that works now
---
basis/pack/pack.factor | 6 ++----
1 file changed, 2 insertions(+), 4 deletions(-)
diff --git a/basis/pack/pack.factor b/basis/pack/pack.factor
index aec4414c71..3cf7dbab4c 100755
--- a/basis/pack/pack.factor
+++ b/basis/pack/pack.factor
@@ -113,9 +113,7 @@ CONSTANT: packed-length-table
MACRO: pack ( str -- quot )
[ pack-table at '[ _ execute ] ] { } map-as
- '[ _ spread ]
- '[ _ input<sequence ]
- '[ _ B{ } append-outputs-as ] ;
+ '[ [ [ _ spread ] input<sequence ] B{ } append-outputs-as ] ;
PRIVATE>
@@ -143,7 +141,7 @@ MACRO: unpack ( str -- quot )
[ [ ch>packed-length ] { } map-as start/end ]
[ [ unpack-table at '[ @ ] ] { } map-as ] bi
[ '[ [ _ _ ] dip <slice> @ ] ] 3map
- '[ _ cleave ] '[ _ output>array ] ;
+ '[ [ _ cleave ] output>array ] ;
PRIVATE>
From b206c5a2d1cbe95a99a37c8e961422c97b1d0b11 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Fri, 6 Feb 2009 10:54:13 -0600
Subject: [PATCH 09/24] Finishing getting rid of html.elements from basis
---
basis/furnace/chloe-tags/chloe-tags.factor | 76 +++++++++----------
basis/furnace/utilities/utilities.factor | 2 +-
basis/html/components/components.factor | 7 +-
{basis => extra}/html/elements/authors.txt | 0
.../html/elements/elements-docs.factor | 0
.../html/elements/elements-tests.factor | 0
.../html/elements/elements.factor | 0
{basis => extra}/html/elements/summary.txt | 0
{basis => extra}/html/elements/tags.txt | 0
9 files changed, 43 insertions(+), 42 deletions(-)
rename {basis => extra}/html/elements/authors.txt (100%)
rename {basis => extra}/html/elements/elements-docs.factor (100%)
rename {basis => extra}/html/elements/elements-tests.factor (100%)
rename {basis => extra}/html/elements/elements.factor (100%)
rename {basis => extra}/html/elements/summary.txt (100%)
rename {basis => extra}/html/elements/tags.txt (100%)
diff --git a/basis/furnace/chloe-tags/chloe-tags.factor b/basis/furnace/chloe-tags/chloe-tags.factor
index 2be19c00c3..2bdaacdcba 100644
--- a/basis/furnace/chloe-tags/chloe-tags.factor
+++ b/basis/furnace/chloe-tags/chloe-tags.factor
@@ -10,7 +10,6 @@ xml.writer
xml.traversal
xml.syntax
html.components
-html.elements
html.forms
html.templates
html.templates.chloe
@@ -58,14 +57,6 @@ CHLOE: write-atom drop [ write-atom-feeds ] [code] ;
#! Side-effects current namespace.
'[ [ [ _ ] dip link-attr ] each-responder ] [code] ;
-: a-start-tag ( tag -- )
- [ <a ] [code]
- [ attrs>> non-chloe-attrs-only compile-attrs ]
- [ compile-link-attrs ]
- [ compile-a-url ]
- tri
- [ =href a> ] [code] ;
-
: process-attrs ( assoc -- newassoc )
[ "@" ?head [ value present ] when ] assoc-map ;
@@ -76,54 +67,61 @@ CHLOE: write-atom drop [ write-atom-feeds ] [code] ;
[ non-chloe-attrs ]
[ compile-link-attrs ]
[ compile-a-url ] tri
- [ swap "href" swap set-at ] [code] ;
+ [ present swap "href" swap [ set-at ] keep ] [code] ;
CHLOE: a
- [ a-attrs ]
- [ compile-children>string ] bi
- [ <unescaped> [XML <a><-></a> XML] swap >>attrs ]
- [xml-code] ;
+ [
+ [ a-attrs ]
+ [ compile-children>string ] bi
+ [ <unescaped> [XML <a><-></a> XML] second swap >>attrs ]
+ [xml-code]
+ ] compile-with-scope ;
CHLOE: base
compile-a-url [ [XML <base href=<->/> XML] ] [xml-code] ;
+USE: io.streams.string
+
: compile-hidden-form-fields ( for -- )
'[
- <div "display: none;" =style div>
+ [
_ [ "," split [ hidden render ] each ] when*
nested-forms get " " join f like nested-forms-key hidden-form-field
[ modify-form ] each-responder
- </div>
+ ] with-string-writer <unescaped>
+ [XML <div style="display:none;"><-></div> XML]
] [code] ;
-: compile-form-attrs ( method action attrs -- )
- [ <form ] [code]
- [ compile-attr [ =method ] [code] ]
- [ compile-attr [ resolve-base-path =action ] [code] ]
- [ compile-attrs ]
- tri*
- [ form> ] [code] ;
+: (compile-form-attrs) ( method action -- )
+ ! Leaves an assoc on the stack at runtime
+ [ compile-attr [ "method" pick set-at ] [code] ]
+ [ compile-attr [ resolve-base-path "action" pick set-at ] [code] ]
+ bi* ;
-: form-start-tag ( tag -- )
- [
- [ "method" optional-attr "post" or ]
- [ "action" required-attr ]
- [ attrs>> non-chloe-attrs-only ] tri
- compile-form-attrs
- ]
- [ "for" optional-attr compile-hidden-form-fields ] bi ;
+: compile-method/action ( tag -- )
+ ! generated code is ( assoc -- assoc )
+ [ "method" optional-attr "post" or ]
+ [ "action" required-attr ] bi
+ (compile-form-attrs) ;
-: form-end-tag ( tag -- )
- drop [ </form> ] [code] ;
+: compile-form-attrs ( tag -- )
+ [ non-chloe-attrs ]
+ [ compile-link-attrs ]
+ [ compile-method/action ] tri ;
+
+: hidden-fields ( tag -- )
+ "for" optional-attr compile-hidden-form-fields ;
CHLOE: form
[
- {
- [ compile-link-attrs ]
- [ form-start-tag ]
- [ compile-children ]
- [ form-end-tag ]
- } cleave
+ [ compile-form-attrs ]
+ [ hidden-fields ]
+ [ compile-children>string ] tri
+ [
+ <unescaped> [XML <form><-><-></form> XML] second
+ swap >>attrs
+ write-xml
+ ] [code]
] compile-with-scope ;
: button-tag-markup ( -- xml )
diff --git a/basis/furnace/utilities/utilities.factor b/basis/furnace/utilities/utilities.factor
index 4a9f71e8a9..716e708303 100755
--- a/basis/furnace/utilities/utilities.factor
+++ b/basis/furnace/utilities/utilities.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces make assocs sequences kernel classes splitting
words vocabs.loader accessors strings combinators arrays
-continuations present fry urls http http.server xml.literals xml.writer
+continuations present fry urls http http.server xml.syntax xml.writer
http.server.redirection http.server.remapping ;
IN: furnace.utilities
diff --git a/basis/html/components/components.factor b/basis/html/components/components.factor
index 82bb75015e..2b18e28351 100644
--- a/basis/html/components/components.factor
+++ b/basis/html/components/components.factor
@@ -11,7 +11,7 @@ IN: html.components
GENERIC: render* ( value name renderer -- xml )
-: render ( name renderer -- )
+: render>xml ( name renderer -- xml )
prepare-value
[
dup validation-error?
@@ -20,7 +20,10 @@ GENERIC: render* ( value name renderer -- xml )
if
] 2dip
render*
- swap 2array write-xml ;
+ swap 2array ;
+
+: render ( name renderer -- )
+ render>xml write-xml ;
SINGLETON: label
diff --git a/basis/html/elements/authors.txt b/extra/html/elements/authors.txt
similarity index 100%
rename from basis/html/elements/authors.txt
rename to extra/html/elements/authors.txt
diff --git a/basis/html/elements/elements-docs.factor b/extra/html/elements/elements-docs.factor
similarity index 100%
rename from basis/html/elements/elements-docs.factor
rename to extra/html/elements/elements-docs.factor
diff --git a/basis/html/elements/elements-tests.factor b/extra/html/elements/elements-tests.factor
similarity index 100%
rename from basis/html/elements/elements-tests.factor
rename to extra/html/elements/elements-tests.factor
diff --git a/basis/html/elements/elements.factor b/extra/html/elements/elements.factor
similarity index 100%
rename from basis/html/elements/elements.factor
rename to extra/html/elements/elements.factor
diff --git a/basis/html/elements/summary.txt b/extra/html/elements/summary.txt
similarity index 100%
rename from basis/html/elements/summary.txt
rename to extra/html/elements/summary.txt
diff --git a/basis/html/elements/tags.txt b/extra/html/elements/tags.txt
similarity index 100%
rename from basis/html/elements/tags.txt
rename to extra/html/elements/tags.txt
From 05632b85254fe0bc5968ae934d3629049a2f7f78 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 6 Feb 2009 11:03:52 -0600
Subject: [PATCH 10/24] Don't use complex.h since *BSDs don't have it in latest
release versions (gah!); add DLLEXPORT for ffi_test_45 to make it work on
Windows
---
vm/ffi_test.c | 2 +-
vm/ffi_test.h | 2 +-
vm/master.h | 1 -
3 files changed, 2 insertions(+), 3 deletions(-)
diff --git a/vm/ffi_test.c b/vm/ffi_test.c
index 36147795d1..c7a9f7d890 100755
--- a/vm/ffi_test.c
+++ b/vm/ffi_test.c
@@ -303,7 +303,7 @@ struct test_struct_14 ffi_test_44(void)
return retval;
}
-complex float ffi_test_45(complex float x, complex double y)
+_Complex float ffi_test_45(_Complex float x, _Complex double y)
{
return x + 2 * y;
}
diff --git a/vm/ffi_test.h b/vm/ffi_test.h
index de48d6dc5b..42ab8d71d1 100755
--- a/vm/ffi_test.h
+++ b/vm/ffi_test.h
@@ -89,4 +89,4 @@ DLLEXPORT struct test_struct_16 ffi_test_43(float x, int a);
DLLEXPORT struct test_struct_14 ffi_test_44();
-complex float ffi_test_45(complex float x, complex double y);
+DLLEXPORT _Complex float ffi_test_45(_Complex float x, _Complex double y);
diff --git a/vm/master.h b/vm/master.h
index 01b2335841..86b5223eaa 100644
--- a/vm/master.h
+++ b/vm/master.h
@@ -8,7 +8,6 @@
#include <fcntl.h>
#include <limits.h>
#include <math.h>
-#include <complex.h>
#include <stdbool.h>
#include <setjmp.h>
From 47a751ad6cb3c9e695e9deb27873f1447b1431ee Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Fri, 6 Feb 2009 11:44:58 -0600
Subject: [PATCH 11/24] Slight cleanup and fixing unit test
---
basis/furnace/chloe-tags/chloe-tags.factor | 13 +++++--------
basis/furnace/utilities/utilities.factor | 8 +++++---
basis/html/templates/chloe/chloe-tests.factor | 2 +-
3 files changed, 11 insertions(+), 12 deletions(-)
diff --git a/basis/furnace/chloe-tags/chloe-tags.factor b/basis/furnace/chloe-tags/chloe-tags.factor
index 2bdaacdcba..d7d9ae9ebb 100644
--- a/basis/furnace/chloe-tags/chloe-tags.factor
+++ b/basis/furnace/chloe-tags/chloe-tags.factor
@@ -19,6 +19,7 @@ http
http.server
http.server.redirection
http.server.responses
+io.streams.string
furnace.utilities ;
IN: furnace.chloe-tags
@@ -80,16 +81,12 @@ CHLOE: a
CHLOE: base
compile-a-url [ [XML <base href=<->/> XML] ] [xml-code] ;
-USE: io.streams.string
-
: compile-hidden-form-fields ( for -- )
'[
- [
- _ [ "," split [ hidden render ] each ] when*
- nested-forms get " " join f like nested-forms-key hidden-form-field
- [ modify-form ] each-responder
- ] with-string-writer <unescaped>
- [XML <div style="display:none;"><-></div> XML]
+ _ [ "," split [ hidden render>xml ] map ] [ f ] if*
+ nested-forms get " " join f like nested-forms-key hidden-form-field>xml
+ [ [ modify-form ] each-responder ] with-string-writer <unescaped>
+ [XML <div style="display: none;"><-><-><-></div> XML]
] [code] ;
: (compile-form-attrs) ( method action -- )
diff --git a/basis/furnace/utilities/utilities.factor b/basis/furnace/utilities/utilities.factor
index 716e708303..a2d4c4d996 100755
--- a/basis/furnace/utilities/utilities.factor
+++ b/basis/furnace/utilities/utilities.factor
@@ -81,11 +81,13 @@ GENERIC: modify-form ( responder -- )
M: object modify-form drop ;
-: hidden-form-field ( value name -- )
+: hidden-form-field>xml ( value name -- xml )
over [
[XML <input type="hidden" value=<-> name=<->/> XML]
- write-xml
- ] [ 2drop ] if ;
+ ] [ drop ] if ;
+
+: hidden-form-field ( value name -- )
+ hidden-form-field>xml write-xml ;
: nested-forms-key "__n" ;
diff --git a/basis/html/templates/chloe/chloe-tests.factor b/basis/html/templates/chloe/chloe-tests.factor
index 184f57051a..4e454dcee4 100644
--- a/basis/html/templates/chloe/chloe-tests.factor
+++ b/basis/html/templates/chloe/chloe-tests.factor
@@ -135,7 +135,7 @@ TUPLE: person first-name last-name ;
[ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test
-[ "<form method='post' action='foo'><div style='display: none;'><input type=\"hidden\" value=\"a\" name=\"__n\"/></div></form>" ] [
+[ "<form method=\"post\" action=\"foo\"><div style=\"display: none;\"><input type=\"hidden\" value=\"a\" name=\"__n\"/></div></form>" ] [
[
"test10" test-template call-template
] run-template
From 173b0ee78d7c659f9205dfee80fca8d8d91ea0b4 Mon Sep 17 00:00:00 2001
From: sheeple <sheeple@oberon.local>
Date: Fri, 6 Feb 2009 12:21:53 -0600
Subject: [PATCH 12/24] Add some more tests for complex numbers in FFI
---
basis/compiler/tests/alien.factor | 14 +++++++++++---
vm/ffi_test.c | 12 +++++++++++-
vm/ffi_test.h | 6 +++++-
3 files changed, 27 insertions(+), 5 deletions(-)
diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor
index b9c62f1429..8830c59b31 100644
--- a/basis/compiler/tests/alien.factor
+++ b/basis/compiler/tests/alien.factor
@@ -559,9 +559,17 @@ FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
[ ] [ stack-frame-bustage 2drop ] unit-test
-FUNCTION: complex-float ffi_test_45 ( complex-float x, complex-double y ) ;
+FUNCTION: complex-float ffi_test_45 ( int x ) ;
+
+[ C{ 0.0 3.0 } ] [ 3 ffi_test_45 ] unit-test
+
+FUNCTION: complex-double ffi_test_46 ( int x ) ;
+
+[ C{ 0.0 3.0 } ] [ 3 ffi_test_46 ] unit-test
+
+FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
[ C{ 4.0 4.0 } ] [
C{ 1.0 2.0 }
- C{ 1.5 1.0 } ffi_test_45
-] unit-test
\ No newline at end of file
+ C{ 1.5 1.0 } ffi_test_47
+] unit-test
diff --git a/vm/ffi_test.c b/vm/ffi_test.c
index c7a9f7d890..a5a43cf2ae 100755
--- a/vm/ffi_test.c
+++ b/vm/ffi_test.c
@@ -303,7 +303,17 @@ struct test_struct_14 ffi_test_44(void)
return retval;
}
-_Complex float ffi_test_45(_Complex float x, _Complex double y)
+_Complex float ffi_test_45(int x)
+{
+ return x;
+}
+
+_Complex double ffi_test_46(int x)
+{
+ return x;
+}
+
+_Complex float ffi_test_47(_Complex float x, _Complex double y)
{
return x + 2 * y;
}
diff --git a/vm/ffi_test.h b/vm/ffi_test.h
index 42ab8d71d1..f8634b304e 100755
--- a/vm/ffi_test.h
+++ b/vm/ffi_test.h
@@ -89,4 +89,8 @@ DLLEXPORT struct test_struct_16 ffi_test_43(float x, int a);
DLLEXPORT struct test_struct_14 ffi_test_44();
-DLLEXPORT _Complex float ffi_test_45(_Complex float x, _Complex double y);
+DLLEXPORT _Complex float ffi_test_45(int x);
+
+DLLEXPORT _Complex double ffi_test_46(int x);
+
+DLLEXPORT _Complex float ffi_test_47(_Complex float x, _Complex double y);
From 01c2e26dfecbd015cdfb6226d0e0efb03f950019 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 6 Feb 2009 12:30:11 -0600
Subject: [PATCH 13/24] Fix alien tests, oops
---
basis/compiler/tests/alien.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor
index 8830c59b31..f3c2deb2d8 100644
--- a/basis/compiler/tests/alien.factor
+++ b/basis/compiler/tests/alien.factor
@@ -561,11 +561,11 @@ FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
FUNCTION: complex-float ffi_test_45 ( int x ) ;
-[ C{ 0.0 3.0 } ] [ 3 ffi_test_45 ] unit-test
+[ C{ 3.0 0.0 } ] [ 3 ffi_test_45 ] unit-test
FUNCTION: complex-double ffi_test_46 ( int x ) ;
-[ C{ 0.0 3.0 } ] [ 3 ffi_test_46 ] unit-test
+[ C{ 3.0 0.0 } ] [ 3 ffi_test_46 ] unit-test
FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
From 01f6c5a7f646ddd2fb2d969876b83c6b2ef29d2d Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 6 Feb 2009 16:40:14 -0600
Subject: [PATCH 14/24] add a test for saving bitmaps, refactor load-bitmap a
bit
---
extra/graphics/bitmap/bitmap-tests.factor | 30 ++++++++++++++++-------
extra/graphics/bitmap/bitmap.factor | 27 ++++++++++++--------
2 files changed, 38 insertions(+), 19 deletions(-)
diff --git a/extra/graphics/bitmap/bitmap-tests.factor b/extra/graphics/bitmap/bitmap-tests.factor
index 15e960084a..ca8be85e12 100644
--- a/extra/graphics/bitmap/bitmap-tests.factor
+++ b/extra/graphics/bitmap/bitmap-tests.factor
@@ -1,15 +1,27 @@
-USING: graphics.bitmap graphics.viewer ;
+USING: graphics.bitmap graphics.viewer io.encodings.binary
+io.files io.files.unique kernel tools.test ;
IN: graphics.bitmap.tests
-: test-bitmap24 ( -- )
- "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" bitmap. ;
+: test-bitmap32-alpha ( -- path )
+ "resource:extra/graphics/bitmap/test-images/32alpha.bmp" ;
-: test-bitmap8 ( -- )
- "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" bitmap. ;
+: test-bitmap24 ( -- path )
+ "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" ;
-: test-bitmap4 ( -- )
- "resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" bitmap. ;
+: test-bitmap8 ( -- path )
+ "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" ;
-: test-bitmap1 ( -- )
- "resource:extra/graphics/bitmap/test-images/1bit.bmp" bitmap. ;
+: test-bitmap4 ( -- path )
+ "resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" ;
+: test-bitmap1 ( -- path )
+ "resource:extra/graphics/bitmap/test-images/1bit.bmp" ;
+
+[ t ]
+[
+ test-bitmap24
+ [ binary file-contents ] [ load-bitmap ] bi
+
+ "test-bitmap24" unique-file
+ [ save-bitmap ] [ binary file-contents ] bi =
+] unit-test
diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor
index bd34a9ee41..a1cf37c8a1 100755
--- a/extra/graphics/bitmap/bitmap.factor
+++ b/extra/graphics/bitmap/bitmap.factor
@@ -1,11 +1,10 @@
-! Copyright (C) 2007 Doug Coleman.
+! Copyright (C) 2007, 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-
-USING: alien arrays byte-arrays combinators summary
-io io.binary io.files kernel libc math
-math.functions math.bitwise namespaces opengl opengl.gl
-prettyprint sequences strings ui ui.gadgets.panes fry
-io.encodings.binary accessors grouping macros alien.c-types ;
+USING: accessors alien alien.c-types arrays byte-arrays columns
+combinators fry grouping io io.binary io.encodings.binary
+io.files kernel libc macros math math.bitwise math.functions
+namespaces opengl opengl.gl prettyprint sequences strings
+summary ui ui.gadgets.panes ;
IN: graphics.bitmap
! Currently can only handle 24/32bit bitmaps.
@@ -14,6 +13,7 @@ IN: graphics.bitmap
TUPLE: bitmap magic size reserved offset header-length width
height planes bit-count compression size-image
x-pels y-pels color-used color-important rgb-quads color-index
+alpha-channel-zero?
array ;
: array-copy ( bitmap array -- bitmap array' )
@@ -97,12 +97,19 @@ M: bitmap-magic summary
dup rgb-quads-length read >>rgb-quads
dup color-index-length read >>color-index ;
-: load-bitmap ( path -- bitmap )
+: (load-bitmap) ( path -- bitmap )
binary [
bitmap new
parse-file-header parse-bitmap-header parse-bitmap
- ] with-file-reader
- dup raw-bitmap>array >>array ;
+ ] with-file-reader ;
+
+: alpha-channel-zero? ( bitmap -- ? )
+ array>> 4 <sliced-groups> 3 <column> [ 0 = ] all? ;
+
+: load-bitmap ( path -- bitmap )
+ (load-bitmap)
+ dup raw-bitmap>array >>array
+ dup alpha-channel-zero? >>alpha-channel-zero? ;
: write2 ( n -- ) 2 >le write ;
: write4 ( n -- ) 4 >le write ;
From 71d176716bcbc310b0e72536eb30082af0be5625 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 6 Feb 2009 16:53:41 -0600
Subject: [PATCH 15/24] fix 24-game compile error
---
extra/24-game/24-game.factor | 5 +++--
1 file changed, 3 insertions(+), 2 deletions(-)
diff --git a/extra/24-game/24-game.factor b/extra/24-game/24-game.factor
index 126215ab13..f842d5f4cb 100644
--- a/extra/24-game/24-game.factor
+++ b/extra/24-game/24-game.factor
@@ -15,7 +15,8 @@ SYMBOL: commands
{ nop rot -rot swap spin swapd } amb-execute ;
: makes-24? ( a b c d -- ? )
[
- 2 [ some-rots do-something ] times
+ some-rots do-something
+ some-rots do-something
maybe-swap do-something
24 =
]
@@ -60,4 +61,4 @@ DEFER: check-status
: 24-able ( -- vector ) build-quad dup 24-able? [ drop build-quad ] unless ;
: set-commands ( -- ) { + - * / rot swap q } commands set ;
: play-game ( -- ) set-commands 24-able repeat ;
-MAIN: play-game
\ No newline at end of file
+MAIN: play-game
From 3df4cfb65164bed7ca4b4ec68056c367108fe8bf Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 6 Feb 2009 16:58:17 -0600
Subject: [PATCH 16/24] fix words help-lint
---
core/words/words-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor
index 764df9924c..4dfa2d49bc 100644
--- a/core/words/words-docs.factor
+++ b/core/words/words-docs.factor
@@ -107,7 +107,7 @@ $nl
{ { { $snippet "\"help\"" } ", " { $snippet "\"help-loc\"" } ", " { $snippet "\"help-parent\"" } } { "Where word help is stored - " { $link "writing-help" } } }
- { { $snippet "\"infer\"" } { $link "compiler-transforms" } }
+ { { $snippet "\"infer\"" } { $link "macros" } }
{ { { $snippet "\"inferred-effect\"" } } { $link "inference" } }
From e0e333b449e8e1c2609f127e02c9316683361357 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 6 Feb 2009 17:13:47 -0600
Subject: [PATCH 17/24] fix link
---
basis/html/templates/chloe/chloe-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/html/templates/chloe/chloe-docs.factor b/basis/html/templates/chloe/chloe-docs.factor
index b2259e629e..18e6db66f6 100644
--- a/basis/html/templates/chloe/chloe-docs.factor
+++ b/basis/html/templates/chloe/chloe-docs.factor
@@ -261,7 +261,7 @@ $nl
ARTICLE: "html.templates.chloe.extend.components.example" "An example of a custom Chloe component"
"As an example, let's develop a custom Chloe component which renders an image stored in a form value. Since the component does not require any configuration, we can define a singleton class:"
{ $code "SINGLETON: image" }
-"Now we define a method on the " { $link render* } " generic word which renders the image using " { $vocab-link "xml.literals" } ":"
+"Now we define a method on the " { $link render* } " generic word which renders the image using " { $link { "xml.syntax" "literals" } } ":"
{ $code "M: image render* 2drop [XML <img src=<-> /> XML] ;" }
"Finally, we can define a Chloe component:"
{ $code "COMPONENT: image" }
From 89c0dd21ddde9ff339cbd7c7fdbf6420123afba3 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 6 Feb 2009 17:14:03 -0600
Subject: [PATCH 18/24] fix furnace.utilities lint
---
basis/furnace/utilities/utilities-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/furnace/utilities/utilities-docs.factor b/basis/furnace/utilities/utilities-docs.factor
index d2291786df..6defba54d2 100644
--- a/basis/furnace/utilities/utilities-docs.factor
+++ b/basis/furnace/utilities/utilities-docs.factor
@@ -27,7 +27,7 @@ HELP: hidden-form-field
{ $example
"USING: furnace.utilities io ;"
"\"bar\" \"foo\" hidden-form-field nl"
- "<input type='hidden' name='foo' value='bar'/>"
+ "<input type=\"hidden\" name=\"foo\" value=\"bar\"/>"
}
} ;
From 4cd8bba92e3f175e464d1cf2c917244db382e5ee Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 6 Feb 2009 17:31:03 -0600
Subject: [PATCH 19/24] better warnings on unsupported bmp formats
---
extra/graphics/bitmap/bitmap-tests.factor | 3 +++
extra/graphics/bitmap/bitmap.factor | 12 +++++-------
2 files changed, 8 insertions(+), 7 deletions(-)
diff --git a/extra/graphics/bitmap/bitmap-tests.factor b/extra/graphics/bitmap/bitmap-tests.factor
index ca8be85e12..f8a125e855 100644
--- a/extra/graphics/bitmap/bitmap-tests.factor
+++ b/extra/graphics/bitmap/bitmap-tests.factor
@@ -8,6 +8,9 @@ IN: graphics.bitmap.tests
: test-bitmap24 ( -- path )
"resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" ;
+: test-bitmap16 ( -- path )
+ "resource:extra/graphics/bitmap/test-images/rgb16bit.bmp" ;
+
: test-bitmap8 ( -- path )
"resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" ;
diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor
index a1cf37c8a1..f8008dc7c1 100755
--- a/extra/graphics/bitmap/bitmap.factor
+++ b/extra/graphics/bitmap/bitmap.factor
@@ -39,20 +39,18 @@ MACRO: (nbits>bitmap) ( bits -- )
[ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
[ color-index>> >array ] bi [ swap nth ] with map concat ;
-: 4bit>array ( bitmap -- array )
- [ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
- [ color-index>> >array ] bi [ swap nth ] with map concat ;
+ERROR: bmp-not-supported n ;
: raw-bitmap>array ( bitmap -- array )
dup bit-count>>
{
{ 32 [ color-index>> ] }
{ 24 [ color-index>> ] }
- { 16 [ "16bit" throw ] }
+ { 16 [ bmp-not-supported ] }
{ 8 [ 8bit>array ] }
- { 4 [ 4bit>array ] }
- { 2 [ "2bit" throw ] }
- { 1 [ "1bit" throw ] }
+ { 4 [ bmp-not-supported ] }
+ { 2 [ bmp-not-supported ] }
+ { 1 [ bmp-not-supported ] }
} case >byte-array ;
ERROR: bitmap-magic ;
From 43a91efde99941c89f5737ca2d17812fa4739e34 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 6 Feb 2009 18:22:28 -0600
Subject: [PATCH 20/24] rename err_no to errno, clear_err_no to clear-errno,
move them to libc, update usages
---
basis/io/backend/unix/unix.factor | 12 ++++++------
basis/io/sockets/secure/unix/unix.factor | 2 +-
basis/io/sockets/unix/unix.factor | 14 +++++++-------
basis/libc/libc.factor | 12 ++++++++++--
basis/unix/unix.factor | 9 ++-------
5 files changed, 26 insertions(+), 23 deletions(-)
diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor
index 4bc8868a3c..d86a72c665 100644
--- a/basis/io/backend/unix/unix.factor
+++ b/basis/io/backend/unix/unix.factor
@@ -84,8 +84,8 @@ M: fd refill
fd>> over buffer>> [ buffer-end ] [ buffer-capacity ] bi read
{
{ [ dup 0 >= ] [ swap buffer>> n>buffer f ] }
- { [ err_no EINTR = ] [ 2drop +retry+ ] }
- { [ err_no EAGAIN = ] [ 2drop +input+ ] }
+ { [ errno EINTR = ] [ 2drop +retry+ ] }
+ { [ errno EAGAIN = ] [ 2drop +input+ ] }
[ (io-error) ]
} cond ;
@@ -104,8 +104,8 @@ M: fd drain
over buffer>> buffer-consume
buffer>> buffer-empty? f +output+ ?
] }
- { [ err_no EINTR = ] [ 2drop +retry+ ] }
- { [ err_no EAGAIN = ] [ 2drop +output+ ] }
+ { [ errno EINTR = ] [ 2drop +retry+ ] }
+ { [ errno EAGAIN = ] [ 2drop +output+ ] }
[ (io-error) ]
} cond ;
@@ -143,7 +143,7 @@ M: stdin dispose*
stdin data>> handle-fd buffer buffer-end size read
dup 0 < [
drop
- err_no EINTR = [ buffer stdin size refill-stdin ] [ (io-error) ] if
+ errno EINTR = [ buffer stdin size refill-stdin ] [ (io-error) ] if
] [
size = [ "Error reading stdin pipe" throw ] unless
size buffer n>buffer
@@ -177,7 +177,7 @@ TUPLE: mx-port < port mx ;
: multiplexer-error ( n -- n )
dup 0 < [
- err_no [ EAGAIN = ] [ EINTR = ] bi or
+ errno [ EAGAIN = ] [ EINTR = ] bi or
[ drop 0 ] [ (io-error) ] if
] when ;
diff --git a/basis/io/sockets/secure/unix/unix.factor b/basis/io/sockets/secure/unix/unix.factor
index 8419246eb6..f1f39a0559 100644
--- a/basis/io/sockets/secure/unix/unix.factor
+++ b/basis/io/sockets/secure/unix/unix.factor
@@ -15,7 +15,7 @@ M: ssl-handle handle-fd file>> handle-fd ;
ERR_get_error dup zero? [
drop
{
- { -1 [ err_no ECONNRESET = [ premature-close ] [ (io-error) ] if ] }
+ { -1 [ errno ECONNRESET = [ premature-close ] [ (io-error) ] if ] }
{ 0 [ premature-close ] }
} case
] [ nip (ssl-error) ] if ;
diff --git a/basis/io/sockets/unix/unix.factor b/basis/io/sockets/unix/unix.factor
index f209df5862..e701874afd 100644
--- a/basis/io/sockets/unix/unix.factor
+++ b/basis/io/sockets/unix/unix.factor
@@ -37,8 +37,8 @@ M: object (get-remote-address) ( handle local -- sockaddr )
dup handle>> handle-fd f 0 write
{
{ [ 0 = ] [ drop ] }
- { [ err_no EAGAIN = ] [ dup +output+ wait-for-port wait-to-connect ] }
- { [ err_no EINTR = ] [ wait-to-connect ] }
+ { [ errno EAGAIN = ] [ dup +output+ wait-for-port wait-to-connect ] }
+ { [ errno EINTR = ] [ wait-to-connect ] }
[ (io-error) ]
} cond ;
@@ -46,7 +46,7 @@ M: object establish-connection ( client-out remote -- )
[ drop ] [ [ handle>> handle-fd ] [ make-sockaddr/size ] bi* connect ] 2bi
{
{ [ 0 = ] [ drop ] }
- { [ err_no EINPROGRESS = ] [
+ { [ errno EINPROGRESS = ] [
[ +output+ wait-for-port ] [ wait-to-connect ] bi
] }
[ (io-error) ]
@@ -78,8 +78,8 @@ M: object (accept) ( server addrspec -- fd sockaddr )
2dup do-accept
{
{ [ over 0 >= ] [ [ 2nip <fd> init-fd ] dip ] }
- { [ err_no EINTR = ] [ 2drop (accept) ] }
- { [ err_no EAGAIN = ] [
+ { [ errno EINTR = ] [ 2drop (accept) ] }
+ { [ errno EAGAIN = ] [
2drop
[ drop +input+ wait-for-port ]
[ (accept) ]
@@ -121,10 +121,10 @@ M: unix (receive) ( datagram -- packet sockaddr )
:: do-send ( packet sockaddr len socket datagram -- )
socket handle-fd packet dup length 0 sockaddr len sendto
0 < [
- err_no EINTR = [
+ errno EINTR = [
packet sockaddr len socket datagram do-send
] [
- err_no EAGAIN = [
+ errno EAGAIN = [
datagram +output+ wait-for-port
packet sockaddr len socket datagram do-send
] [
diff --git a/basis/libc/libc.factor b/basis/libc/libc.factor
index 1e751833a2..bcfb97750f 100644
--- a/basis/libc/libc.factor
+++ b/basis/libc/libc.factor
@@ -2,10 +2,18 @@
! Copyright (C) 2007, 2008 Slava Pestov
! Copyright (C) 2007, 2008 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
-USING: alien assocs continuations destructors kernel
-namespaces accessors sets summary ;
+USING: alien alien.syntax assocs continuations destructors
+kernel namespaces accessors sets summary ;
IN: libc
+LIBRARY: factor
+
+: errno ( -- int )
+ "int" "factor" "err_no" { } alien-invoke ;
+
+: clear-errno ( -- )
+ "void" "factor" "clear_err_no" { } alien-invoke ;
+
<PRIVATE
: (malloc) ( size -- alien )
diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor
index 42444261e2..76613934af 100644
--- a/basis/unix/unix.factor
+++ b/basis/unix/unix.factor
@@ -37,18 +37,13 @@ C-STRUCT: group
{ "int" "gr_gid" }
{ "char**" "gr_mem" } ;
-LIBRARY: factor
-
-FUNCTION: void clear_err_no ( ) ;
-FUNCTION: int err_no ( ) ;
-
LIBRARY: libc
FUNCTION: char* strerror ( int errno ) ;
ERROR: unix-error errno message ;
-: (io-error) ( -- * ) err_no dup strerror unix-error ;
+: (io-error) ( -- * ) errno dup strerror unix-error ;
: io-error ( n -- ) 0 < [ (io-error) ] when ;
@@ -61,7 +56,7 @@ MACRO:: unix-system-call ( quot -- )
n ndup quot call dup 0 < [
drop
n narray
- err_no dup strerror
+ errno dup strerror
word unix-system-call-error
] [
n nnip
From 4ebc3203d65576da5a85e9520b5319ffb6b4a73f Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 6 Feb 2009 18:36:00 -0600
Subject: [PATCH 21/24] unbreak bootstrap
---
basis/libc/libc.factor | 4 +---
1 file changed, 1 insertion(+), 3 deletions(-)
diff --git a/basis/libc/libc.factor b/basis/libc/libc.factor
index bcfb97750f..c154544f81 100644
--- a/basis/libc/libc.factor
+++ b/basis/libc/libc.factor
@@ -2,12 +2,10 @@
! Copyright (C) 2007, 2008 Slava Pestov
! Copyright (C) 2007, 2008 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax assocs continuations destructors
+USING: alien assocs continuations destructors
kernel namespaces accessors sets summary ;
IN: libc
-LIBRARY: factor
-
: errno ( -- int )
"int" "factor" "err_no" { } alien-invoke ;
From c8c427ec159b92acf5924e757b5ea3ed95d2e692 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 6 Feb 2009 18:38:41 -0600
Subject: [PATCH 22/24] initial, non-stream-based zlib binding
---
basis/zlib/authors.txt | 1 +
basis/zlib/ffi/authors.txt | 1 +
basis/zlib/ffi/ffi.factor | 30 ++++++++++++++++++++++
basis/zlib/zlib-tests.factor | 9 +++++++
basis/zlib/zlib.factor | 50 ++++++++++++++++++++++++++++++++++++
5 files changed, 91 insertions(+)
create mode 100755 basis/zlib/authors.txt
create mode 100755 basis/zlib/ffi/authors.txt
create mode 100755 basis/zlib/ffi/ffi.factor
create mode 100755 basis/zlib/zlib-tests.factor
create mode 100755 basis/zlib/zlib.factor
diff --git a/basis/zlib/authors.txt b/basis/zlib/authors.txt
new file mode 100755
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/basis/zlib/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/basis/zlib/ffi/authors.txt b/basis/zlib/ffi/authors.txt
new file mode 100755
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/basis/zlib/ffi/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/basis/zlib/ffi/ffi.factor b/basis/zlib/ffi/ffi.factor
new file mode 100755
index 0000000000..bda2809f56
--- /dev/null
+++ b/basis/zlib/ffi/ffi.factor
@@ -0,0 +1,30 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.syntax combinators system ;
+IN: zlib.ffi
+
+<< "zlib" {
+ { [ os winnt? ] [ "zlib1.dll" ] }
+ { [ os macosx? ] [ "libz.dylib" ] }
+ { [ os unix? ] [ "libz.so" ] }
+} cond "cdecl" add-library >>
+
+LIBRARY: zlib
+
+CONSTANT: Z_OK 0
+CONSTANT: Z_STREAM_END 1
+CONSTANT: Z_NEED_DICT 2
+CONSTANT: Z_ERRNO -1
+CONSTANT: Z_STREAM_ERROR -2
+CONSTANT: Z_DATA_ERROR -3
+CONSTANT: Z_MEM_ERROR -4
+CONSTANT: Z_BUF_ERROR -5
+CONSTANT: Z_VERSION_ERROR -6
+
+TYPEDEF: void Bytef
+TYPEDEF: ulong uLongf
+TYPEDEF: ulong uLong
+
+FUNCTION: int compress ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen ) ;
+FUNCTION: int compress2 ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen, int level ) ;
+FUNCTION: int uncompress ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen ) ;
diff --git a/basis/zlib/zlib-tests.factor b/basis/zlib/zlib-tests.factor
new file mode 100755
index 0000000000..0ac77277dc
--- /dev/null
+++ b/basis/zlib/zlib-tests.factor
@@ -0,0 +1,9 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel tools.test zlib classes ;
+IN: zlib.tests
+
+: compress-me ( -- byte-array ) B{ 1 2 3 4 5 } ;
+
+[ t ] [ compress-me [ compress uncompress ] keep = ] unit-test
+[ t ] [ compress-me compress compressed instance? ] unit-test
diff --git a/basis/zlib/zlib.factor b/basis/zlib/zlib.factor
new file mode 100755
index 0000000000..d5eed0b35b
--- /dev/null
+++ b/basis/zlib/zlib.factor
@@ -0,0 +1,50 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.syntax byte-arrays combinators
+kernel math math.functions sequences system accessors
+libc ;
+QUALIFIED: zlib.ffi
+IN: zlib
+
+TUPLE: compressed data length ;
+
+: <compressed> ( data length -- compressed )
+ compressed new
+ swap >>length
+ swap >>data ;
+
+ERROR: zlib-failed n string ;
+
+: zlib-error-message ( n -- * )
+ dup zlib.ffi:Z_ERRNO = [
+ drop errno "native libc error"
+ ] [
+ dup {
+ "no error" "libc_error"
+ "stream error" "data error"
+ "memory error" "buffer error" "zlib version error"
+ } ?nth
+ ] if zlib-failed ;
+
+: zlib-error ( n -- )
+ dup zlib.ffi:Z_OK = [ drop ] [ dup zlib-error-message zlib-failed ] if ;
+
+! Compressed size is up to .001% larger plus 12
+
+: compressed-size ( byte-array -- n )
+ length 1001/1000 * ceiling 12 + ;
+
+: compress ( byte-array -- compressed )
+ [
+ [ compressed-size <byte-array> dup length <ulong> ] keep [
+ dup length zlib.ffi:compress zlib-error
+ ] 3keep drop *ulong head
+ ] keep length <compressed> ;
+
+: uncompress ( compressed -- byte-array )
+ [
+ length>> [ <byte-array> ] keep <ulong> 2dup
+ ] [
+ data>> dup length
+ zlib.ffi:uncompress zlib-error
+ ] bi *ulong head ;
From d5dc7f5db51dca61fcb316298e0bc17aa5db38a6 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 6 Feb 2009 18:40:41 -0600
Subject: [PATCH 23/24] remove bad comment
---
basis/zlib/zlib.factor | 2 --
1 file changed, 2 deletions(-)
diff --git a/basis/zlib/zlib.factor b/basis/zlib/zlib.factor
index d5eed0b35b..b40d9c2a98 100755
--- a/basis/zlib/zlib.factor
+++ b/basis/zlib/zlib.factor
@@ -29,8 +29,6 @@ ERROR: zlib-failed n string ;
: zlib-error ( n -- )
dup zlib.ffi:Z_OK = [ drop ] [ dup zlib-error-message zlib-failed ] if ;
-! Compressed size is up to .001% larger plus 12
-
: compressed-size ( byte-array -- n )
length 1001/1000 * ceiling 12 + ;
From 201296c04043eeb281a28e1b844ca1ee8f9f0147 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 6 Feb 2009 18:46:23 -0600
Subject: [PATCH 24/24] dllexport err_no and clear_err_no
---
vm/io.h | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/vm/io.h b/vm/io.h
index 08c9dd7807..dc7d69edee 100755
--- a/vm/io.h
+++ b/vm/io.h
@@ -1,7 +1,7 @@
void init_c_io(void);
void io_error(void);
-int err_no(void);
-void clear_err_no(void);
+DLLEXPORT int err_no(void);
+DLLEXPORT void clear_err_no(void);
void primitive_fopen(void);
void primitive_fgetc(void);