From babe9bb2fdabd488fcd1293e50b2bb1d0095e3e6 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Wed, 4 Feb 2009 01:25:48 -0600
Subject: [PATCH 01/36] Making xml.dispatch compile
---
basis/xml-rpc/xml-rpc.factor | 8 +++-
basis/xml/dispatch/dispatch-docs.factor | 18 ++++-----
basis/xml/dispatch/dispatch-tests.factor | 4 +-
basis/xml/dispatch/dispatch.factor | 38 ++++++++++---------
.../space-file-decoder.factor | 2 +-
5 files changed, 40 insertions(+), 30 deletions(-)
diff --git a/basis/xml-rpc/xml-rpc.factor b/basis/xml-rpc/xml-rpc.factor
index d9028756f2..304f7400fa 100644
--- a/basis/xml-rpc/xml-rpc.factor
+++ b/basis/xml-rpc/xml-rpc.factor
@@ -113,14 +113,18 @@ M: server-error error.
"Description: " write dup message>> print
"Tag: " write tag>> xml>string print ;
-PROCESS: xml>item ( tag -- object )
+TAGS: xml>item ( tag -- object )
TAG: string xml>item
children>string ;
-TAG: i4/int/double xml>item
+: children>number ( tag -- n )
children>string string>number ;
+TAG: i4 xml>item children>number ;
+TAG: int xml>item children>number ;
+TAG: double xml>item children>number ;
+
TAG: boolean xml>item
dup children>string {
{ [ dup "1" = ] [ 2drop t ] }
diff --git a/basis/xml/dispatch/dispatch-docs.factor b/basis/xml/dispatch/dispatch-docs.factor
index 572a75cd05..d3d24d736c 100644
--- a/basis/xml/dispatch/dispatch-docs.factor
+++ b/basis/xml/dispatch/dispatch-docs.factor
@@ -6,20 +6,20 @@ IN: xml.dispatch
ABOUT: "xml.dispatch"
ARTICLE: "xml.dispatch" "Dispatch on XML tag names"
-"Two parsing words define a system, analogous to generic words, for processing XML. A word can dispatch off the name of the tag that is passed to it. To define such a word, use"
-{ $subsection POSTPONE: PROCESS: }
+"The " { $link "xml.dispatch" } " vocabulary defines a system, analogous to generic words, for processing XML. A word can dispatch off the name of the tag that is passed to it. To define such a word, use"
+{ $subsection POSTPONE: TAGS: }
"and to define a new 'method' for this word, use"
{ $subsection POSTPONE: TAG: } ;
-HELP: PROCESS:
-{ $syntax "PROCESS: word" }
+HELP: TAGS:
+{ $syntax "TAGS: word" }
{ $values { "word" "a new word to define" } }
-{ $description "creates a new word to process XML tags" }
+{ $description "Creates a new word to which dispatches on XML tag names." }
{ $see-also POSTPONE: TAG: } ;
HELP: TAG:
{ $syntax "TAG: tag word definition... ;" }
-{ $values { "tag" "an xml tag name" } { "word" "an XML process" } }
-{ $description "defines what a process should do when it encounters a specific tag" }
-{ $examples { $code "PROCESS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } }
-{ $see-also POSTPONE: PROCESS: } ;
+{ $values { "tag" "an XML tag name" } { "word" "an XML process" } }
+{ $description "Defines a 'method' on a word created with " { $link POSTPONE: TAGS: } ". It determines what such a word should do for an argument that is has the given name." }
+{ $examples { $code "TAGS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } }
+{ $see-also POSTPONE: TAGS: } ;
diff --git a/basis/xml/dispatch/dispatch-tests.factor b/basis/xml/dispatch/dispatch-tests.factor
index 6f3179bc02..e76a759291 100644
--- a/basis/xml/dispatch/dispatch-tests.factor
+++ b/basis/xml/dispatch/dispatch-tests.factor
@@ -4,7 +4,7 @@ USING: xml io kernel math sequences strings xml.utilities
tools.test math.parser xml.dispatch ;
IN: xml.dispatch.tests
-PROCESS: calculate ( tag -- n )
+TAGS: calculate ( tag -- n )
: calc-2children ( tag -- n n )
children-tags first2 [ calculate ] dip calculate ;
@@ -29,3 +29,5 @@ TAG: neg calculate
"<math><times><add><number>1</number><number>3</number></add><neg><number>-8</number></neg></times></math>"
calc-arith
] unit-test
+
+\ calc-arith must-infer
diff --git a/basis/xml/dispatch/dispatch.factor b/basis/xml/dispatch/dispatch.factor
index 23cb43cc47..613836aae2 100644
--- a/basis/xml/dispatch/dispatch.factor
+++ b/basis/xml/dispatch/dispatch.factor
@@ -1,27 +1,31 @@
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: words assocs kernel accessors parser sequences summary
-lexer splitting fry ;
+lexer splitting fry combinators ;
IN: xml.dispatch
-TUPLE: process-missing process tag ;
-M: process-missing summary
- drop "Tag not implemented on process" ;
+TUPLE: no-tag name word ;
+M: no-tag summary
+ drop "The tag-dispatching word has no method for the given tag name" ;
-: run-process ( tag word -- )
- 2dup "xtable" word-prop
- [ dup main>> ] dip at* [ 2nip call ] [
- drop \ process-missing boa throw
- ] if ;
+: compile-tags ( word xtable -- quot )
+ >alist swap '[ _ no-tag boa throw ] [ ] like suffix
+ '[ dup main>> _ case ] ;
-: PROCESS:
+: define-tags ( word -- )
+ dup dup "xtable" word-prop compile-tags define ;
+
+: define-tag ( string word quot -- )
+ -rot [ "xtable" word-prop set-at ] [ define-tags ] bi ;
+
+:: define-tag ( string word quot -- )
+ quot string word "xtable" word-prop set-at
+ word define-tags ;
+
+: TAGS:
CREATE
- dup H{ } clone "xtable" set-word-prop
- dup '[ _ run-process ] define ; parsing
+ [ H{ } clone "xtable" set-word-prop ]
+ [ define-tags ] bi ; parsing
: TAG:
- scan scan-word
- parse-definition
- swap "xtable" word-prop
- rot "/" split [ [ 2dup ] dip swap set-at ] each 2drop ;
- parsing
+ scan scan-word parse-definition define-tag ; parsing
diff --git a/extra/4DNav/space-file-decoder/space-file-decoder.factor b/extra/4DNav/space-file-decoder/space-file-decoder.factor
index 872ddbcee3..bd3915cb36 100755
--- a/extra/4DNav/space-file-decoder/space-file-decoder.factor
+++ b/extra/4DNav/space-file-decoder/space-file-decoder.factor
@@ -8,7 +8,7 @@ IN: 4DNav.space-file-decoder
: decode-number-array ( x -- y )
"," split [ string>number ] map ;
-PROCESS: adsoda-read-model ( tag -- )
+TAGS: adsoda-read-model ( tag -- )
TAG: dimension adsoda-read-model
children>> first string>number ;
From 009ea7ad4562dc7ec36fa8516c3c9d16f2a42b7a Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Wed, 4 Feb 2009 12:32:47 -0600
Subject: [PATCH 02/36] Fixing bug in XML where prolog isn't considered;
whenever you write XML, the encoding is listed as UTF-8.
---
basis/xml/dispatch/dispatch.factor | 2 +-
basis/xml/tests/test.factor | 1 +
basis/xml/writer/writer-tests.factor | 9 ++++++++-
basis/xml/writer/writer.factor | 2 +-
basis/xml/xml.factor | 21 +++++++++++++++------
5 files changed, 26 insertions(+), 9 deletions(-)
diff --git a/basis/xml/dispatch/dispatch.factor b/basis/xml/dispatch/dispatch.factor
index 613836aae2..9c4a2448c6 100644
--- a/basis/xml/dispatch/dispatch.factor
+++ b/basis/xml/dispatch/dispatch.factor
@@ -9,7 +9,7 @@ M: no-tag summary
drop "The tag-dispatching word has no method for the given tag name" ;
: compile-tags ( word xtable -- quot )
- >alist swap '[ _ no-tag boa throw ] [ ] like suffix
+ >alist swap '[ _ no-tag boa throw ] suffix
'[ dup main>> _ case ] ;
: define-tags ( word -- )
diff --git a/basis/xml/tests/test.factor b/basis/xml/tests/test.factor
index 337c19bfe1..dcd428d9e6 100644
--- a/basis/xml/tests/test.factor
+++ b/basis/xml/tests/test.factor
@@ -67,3 +67,4 @@ SYMBOL: xml-file
[ "x" "<" ] [ "<x value='<'/>" string>xml [ name>> main>> ] [ "value" attr ] bi ] unit-test
[ "foo" ] [ "<!DOCTYPE foo [<!ENTITY bar 'foo'>]><x>&bar;</x>" string>xml children>string ] unit-test
[ T{ xml-chunk f V{ "hello" } } ] [ "hello" string>xml-chunk ] unit-test
+[ "1.1" ] [ "<?xml version='1.1'?><x/>" string>xml prolog>> version>> ] unit-test
diff --git a/basis/xml/writer/writer-tests.factor b/basis/xml/writer/writer-tests.factor
index d09ae08b3f..f414264e11 100644
--- a/basis/xml/writer/writer-tests.factor
+++ b/basis/xml/writer/writer-tests.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: xml.data xml.writer tools.test fry xml kernel multiline
-xml.writer.private io.streams.string xml.utilities sequences ;
+xml.writer.private io.streams.string xml.utilities sequences
+io.encodings.utf8 io.files accessors io.directories ;
IN: xml.writer.tests
\ write-xml must-infer
@@ -59,3 +60,9 @@ IN: xml.writer.tests
[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<foo>\n bar\n</foo>" ]
[ "<foo> bar </foo>" string>xml pprint-xml>string ] unit-test
[ "<foo'>" ] [ "<foo'>" <unescaped> xml>string ] unit-test
+
+: test-file "resource:basis/xml/writer/test.xml" ;
+
+[ ] [ "<?xml version='1.0' encoding='UTF-16BE'?><x/>" string>xml test-file utf8 [ write-xml ] with-file-writer ] unit-test
+[ "x" ] [ test-file file>xml body>> name>> main>> ] unit-test
+[ ] [ test-file delete-file ] unit-test
diff --git a/basis/xml/writer/writer.factor b/basis/xml/writer/writer.factor
index a713790973..4b80e0818e 100755
--- a/basis/xml/writer/writer.factor
+++ b/basis/xml/writer/writer.factor
@@ -164,7 +164,7 @@ M: sequence write-xml
M: prolog write-xml
"<?xml version=" write
[ version>> write-quoted ]
- [ " encoding=" write encoding>> write-quoted ]
+ [ drop " encoding=\"UTF-8\"" write ]
[ standalone>> [ " standalone=\"yes\"" write ] when ] tri
"?>" write ;
diff --git a/basis/xml/xml.factor b/basis/xml/xml.factor
index 5ca486a57f..57c1b6dbd3 100755
--- a/basis/xml/xml.factor
+++ b/basis/xml/xml.factor
@@ -4,7 +4,7 @@ USING: accessors arrays io io.encodings.binary io.files
io.streams.string kernel namespaces sequences strings io.encodings.utf8
xml.data xml.errors xml.elements ascii xml.entities
xml.writer xml.state xml.autoencoding assocs xml.tokenize
-combinators.short-circuit xml.name ;
+combinators.short-circuit xml.name splitting ;
IN: xml
<PRIVATE
@@ -25,7 +25,7 @@ M: object process add-child ;
M: prolog process
xml-stack get
{ V{ { f V{ "" } } } V{ { f V{ } } } } member?
- [ bad-prolog ] unless drop ;
+ [ bad-prolog ] unless add-child ;
: before-main? ( -- ? )
xml-stack get {
@@ -82,14 +82,23 @@ M: closer process
! this does *not* affect the contents of the stack
[ notags ] unless* ;
+: ?first ( seq -- elt/f ) 0 swap ?nth ;
+
: get-prolog ( seq -- prolog )
- first dup prolog? [ drop default-prolog ] unless ;
+ { "" } ?head drop
+ ?first dup prolog?
+ [ drop default-prolog ] unless ;
+
+: cut-prolog ( seq -- newseq )
+ [ [ prolog? not ] [ "" = not ] bi and ] filter ;
: make-xml-doc ( seq -- xml-doc )
[ get-prolog ] keep
- dup [ tag? ] find
- [ assure-tags cut rest no-pre/post no-post-tags ] dip
- swap <xml> ;
+ dup [ tag? ] find [
+ assure-tags cut
+ [ cut-prolog ] [ rest ] bi*
+ no-pre/post no-post-tags
+ ] dip swap <xml> ;
! * Views of XML
From 292ebd4a4cd9f0374b1a109e518fd064d041082a Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Wed, 4 Feb 2009 12:34:18 -0600
Subject: [PATCH 03/36] Fixing xml.dispatch
---
basis/xml/dispatch/dispatch.factor | 5 +----
1 file changed, 1 insertion(+), 4 deletions(-)
diff --git a/basis/xml/dispatch/dispatch.factor b/basis/xml/dispatch/dispatch.factor
index 9c4a2448c6..f6b9e107e3 100644
--- a/basis/xml/dispatch/dispatch.factor
+++ b/basis/xml/dispatch/dispatch.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: words assocs kernel accessors parser sequences summary
-lexer splitting fry combinators ;
+lexer splitting fry combinators locals ;
IN: xml.dispatch
TUPLE: no-tag name word ;
@@ -15,9 +15,6 @@ M: no-tag summary
: define-tags ( word -- )
dup dup "xtable" word-prop compile-tags define ;
-: define-tag ( string word quot -- )
- -rot [ "xtable" word-prop set-at ] [ define-tags ] bi ;
-
:: define-tag ( string word quot -- )
quot string word "xtable" word-prop set-at
word define-tags ;
From c7a070ba8e08f2c39ecfc0de124195c978b277ad Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Wed, 4 Feb 2009 13:25:51 -0600
Subject: [PATCH 04/36] Fixing typo in xml.dispatch
---
basis/xml/dispatch/dispatch.factor | 4 ++++
1 file changed, 4 insertions(+)
diff --git a/basis/xml/dispatch/dispatch.factor b/basis/xml/dispatch/dispatch.factor
index f6b9e107e3..af47f7c14c 100644
--- a/basis/xml/dispatch/dispatch.factor
+++ b/basis/xml/dispatch/dispatch.factor
@@ -8,10 +8,14 @@ TUPLE: no-tag name word ;
M: no-tag summary
drop "The tag-dispatching word has no method for the given tag name" ;
+<PRIVATE
+
: compile-tags ( word xtable -- quot )
>alist swap '[ _ no-tag boa throw ] suffix
'[ dup main>> _ case ] ;
+PRIVATE>
+
: define-tags ( word -- )
dup dup "xtable" word-prop compile-tags define ;
From fa0d5de2e4c903baf3ab5ce26c19535e50127b3d Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Wed, 4 Feb 2009 17:29:35 -0600
Subject: [PATCH 05/36] Speeding up xml.literals by 3x using code generation
---
basis/xml/literals/literals-tests.factor | 2 +-
basis/xml/literals/literals.factor | 113 +++++++++++++++--------
2 files changed, 75 insertions(+), 40 deletions(-)
diff --git a/basis/xml/literals/literals-tests.factor b/basis/xml/literals/literals-tests.factor
index 59bd178f39..ec68a034a6 100644
--- a/basis/xml/literals/literals-tests.factor
+++ b/basis/xml/literals/literals-tests.factor
@@ -55,7 +55,7 @@ IN: xml.literals.tests
[ "<x></x>" ] [ f [XML <x><-></x> XML] xml>string ] unit-test
\ <XML must-infer
-[ { } "" interpolate-xml ] must-infer
+[ [XML <-> XML] ] must-infer
[ [XML <foo><-></foo> <bar val=<->/> XML] ] must-infer
[ xml-chunk ] [ [ [XML <foo/> XML] ] first class ] unit-test
diff --git a/basis/xml/literals/literals.factor b/basis/xml/literals/literals.factor
index f245c7a542..1520afdde4 100644
--- a/basis/xml/literals/literals.factor
+++ b/basis/xml/literals/literals.factor
@@ -3,11 +3,34 @@
USING: xml xml.state kernel sequences fry assocs xml.data
accessors strings make multiline parser namespaces macros
sequences.deep generalizations words combinators
-math present arrays unicode.categories ;
+math present arrays unicode.categories locals.backend
+quotations ;
IN: xml.literals
<PRIVATE
+: each-attrs ( attrs quot -- )
+ [ values [ interpolated? ] filter ] dip each ; inline
+
+: (each-interpolated) ( item quot: ( interpolated -- ) -- )
+ {
+ { [ over interpolated? ] [ call ] }
+ { [ over tag? ] [ [ attrs>> ] dip each-attrs ] }
+ { [ over attrs? ] [ each-attrs ] }
+ { [ over xml? ] [ [ body>> ] dip (each-interpolated) ] }
+ [ 2drop ]
+ } cond ; inline recursive
+
+: each-interpolated ( xml quot -- )
+ '[ _ (each-interpolated) ] deep-each ; inline
+
+: has-interpolated? ( xml -- ? )
+ ! If this becomes a performance problem, it can be improved
+ f swap [ 2drop t ] each-interpolated ;
+
+: when-interpolated ( xml quot -- genquot )
+ [ dup has-interpolated? ] dip [ '[ _ swap ] ] if ; inline
+
: string>chunk ( string -- chunk )
t interpolating? [ string>xml-chunk ] with-variable ;
@@ -16,17 +39,34 @@ IN: xml.literals
DEFER: interpolate-sequence
-: interpolate-attrs ( table attrs -- attrs )
- swap '[
- dup interpolated?
- [ var>> _ at dup [ present ] when ] when
- ] assoc-map [ nip ] assoc-filter ;
+: get-interpolated ( interpolated -- quot )
+ var>> '[ [ _ swap at ] keep ] ;
-: interpolate-tag ( table tag -- tag )
- [ nip name>> ]
- [ attrs>> interpolate-attrs ]
- [ children>> [ interpolate-sequence ] [ drop f ] if* ] 2tri
- <tag> ;
+: ?present ( object -- string )
+ dup [ present ] when ;
+
+: interpolate-attr ( key value -- quot )
+ dup interpolated?
+ [ get-interpolated '[ _ swap @ [ ?present 2array ] dip ] ]
+ [ 2array '[ _ swap ] ] if ;
+
+: filter-nulls ( assoc -- newassoc )
+ [ nip ] assoc-filter ;
+
+: interpolate-attrs ( attrs -- quot )
+ [
+ [ [ interpolate-attr ] { } assoc>map [ ] join ]
+ [ assoc-size ] bi
+ '[ @ _ swap [ narray filter-nulls <attrs> ] dip ]
+ ] when-interpolated ;
+
+: interpolate-tag ( tag -- quot )
+ [
+ [ name>> ]
+ [ attrs>> interpolate-attrs ]
+ [ children>> interpolate-sequence ] tri
+ '[ _ swap @ @ [ <tag> ] dip ]
+ ] when-interpolated ;
GENERIC: push-item ( item -- )
M: string push-item , ;
@@ -37,30 +77,33 @@ M: sequence push-item
M: number push-item present , ;
M: xml-chunk push-item % ;
-GENERIC: interpolate-item ( table item -- )
-M: object interpolate-item nip , ;
-M: tag interpolate-item interpolate-tag , ;
-M: interpolated interpolate-item
- var>> swap at push-item ;
+: concat-interpolate ( array -- newarray )
+ [ [ push-item ] each ] { } make ;
-: interpolate-sequence ( table seq -- seq )
- [ [ interpolate-item ] with each ] { } make ;
+GENERIC: interpolate-item ( item -- quot )
+M: object interpolate-item [ swap ] curry ;
+M: tag interpolate-item interpolate-tag ;
+M: interpolated interpolate-item get-interpolated ;
-: interpolate-xml-doc ( table xml -- xml )
- (clone) [ interpolate-tag ] change-body ;
+: interpolate-sequence ( seq -- quot )
+ [
+ [ [ interpolate-item ] map concat ]
+ [ length ] bi
+ '[ @ _ swap [ narray concat-interpolate ] dip ]
+ ] when-interpolated ;
-: (each-interpolated) ( item quot: ( interpolated -- ) -- )
- {
- { [ over interpolated? ] [ call ] }
- { [ over tag? ] [
- [ attrs>> values [ interpolated? ] filter ] dip each
- ] }
- { [ over xml? ] [ [ body>> ] dip (each-interpolated) ] }
- [ 2drop ]
- } cond ; inline recursive
+GENERIC: [interpolate-xml] ( xml -- quot )
-: each-interpolated ( xml quot -- )
- '[ _ (each-interpolated) ] deep-each ; inline
+M: xml [interpolate-xml]
+ dup body>> interpolate-tag
+ '[ _ (clone) swap @ drop >>body ] ;
+
+M: xml-chunk [interpolate-xml]
+ interpolate-sequence
+ '[ @ drop <xml-chunk> ] ;
+
+MACRO: interpolate-xml ( xml -- quot )
+ [interpolate-xml] ;
: number<-> ( doc -- dup )
0 over [
@@ -69,14 +112,6 @@ M: interpolated interpolate-item
] unless drop
] each-interpolated drop ;
-GENERIC: interpolate-xml ( table xml -- xml )
-
-M: xml interpolate-xml
- interpolate-xml-doc ;
-
-M: xml-chunk interpolate-xml
- interpolate-sequence <xml-chunk> ;
-
: >search-hash ( seq -- hash )
[ dup search ] H{ } map>assoc ;
From 023a44118ae649c9496bd792c80de83b5025b2fd Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Wed, 4 Feb 2009 17:31:25 -0600
Subject: [PATCH 06/36] inverse bug fix
---
extra/inverse/inverse-tests.factor | 3 +++
extra/inverse/inverse.factor | 5 +++--
2 files changed, 6 insertions(+), 2 deletions(-)
diff --git a/extra/inverse/inverse-tests.factor b/extra/inverse/inverse-tests.factor
index a9234fcff4..9d81992eae 100644
--- a/extra/inverse/inverse-tests.factor
+++ b/extra/inverse/inverse-tests.factor
@@ -71,6 +71,9 @@ C: <nil> nil
[ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test
[ ] [ 3 [ _ ] undo ] unit-test
+[ 2.0 ] [ 2 3 ^ [ 3 ^ ] undo ] unit-test
+[ 3.0 ] [ 2 3 ^ [ 2 swap ^ ] undo ] unit-test
+
[ { 1 } ] [ { 1 2 3 } [ { 2 3 } append ] undo ] unit-test
[ { 3 } ] [ { 1 2 3 } [ { 1 2 } prepend ] undo ] unit-test
[ { 1 2 3 } [ { 1 2 } append ] undo ] must-fail
diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor
index a86e673c9c..1006e45e77 100755
--- a/extra/inverse/inverse.factor
+++ b/extra/inverse/inverse.factor
@@ -5,7 +5,7 @@ sequences assocs math arrays stack-checker effects generalizations
continuations debugger classes.tuple namespaces make vectors
bit-arrays byte-arrays strings sbufs math.functions macros
sequences.private combinators mirrors splitting
-combinators.short-circuit fry words.symbol ;
+combinators.short-circuit fry words.symbol generalizations ;
RENAME: _ fry => __
IN: inverse
@@ -163,7 +163,7 @@ ERROR: missing-literal ;
\ - [ + ] [ - ] define-math-inverse
\ * [ / ] [ / ] define-math-inverse
\ / [ * ] [ / ] define-math-inverse
-\ ^ [ recip ^ ] [ [ log ] bi@ / ] define-math-inverse
+\ ^ [ recip ^ ] [ swap [ log ] bi@ / ] define-math-inverse
\ ? 2 [
[ assert-literal ] bi@
@@ -199,6 +199,7 @@ DEFER: _
\ 2array [ 2 assure-length first2 ] define-inverse
\ 3array [ 3 assure-length first3 ] define-inverse
\ 4array [ 4 assure-length first4 ] define-inverse
+\ narray 1 [ [ firstn ] curry ] define-pop-inverse
\ first [ 1array ] define-inverse
\ first2 [ 2array ] define-inverse
From f101ca606da2be44da1c863a88227d34b9839f0a Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 5 Feb 2009 09:09:24 -0600
Subject: [PATCH 07/36] use bi
---
basis/roman/roman.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/roman/roman.factor b/basis/roman/roman.factor
index 81a6d69a09..24713545b1 100644
--- a/basis/roman/roman.factor
+++ b/basis/roman/roman.factor
@@ -31,7 +31,7 @@ ERROR: roman-range-error n ;
] 2each drop ;
: (roman>) ( seq -- n )
- dup [ roman>n ] map swap all-eq? [
+ [ [ roman>n ] map ] [ all-eq? ] bi [
sum
] [
first2 swap -
From b9839b0c320d5962ac2568b437c3adbd5fe00ae6 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Thu, 5 Feb 2009 14:21:36 -0600
Subject: [PATCH 08/36] XML literals work with inverse now
---
{extra => basis}/inverse/authors.txt | 0
{extra => basis}/inverse/inverse-docs.factor | 0
{extra => basis}/inverse/inverse-tests.factor | 0
{extra => basis}/inverse/inverse.factor | 0
{extra => basis}/inverse/summary.txt | 0
{extra => basis}/inverse/tags.txt | 0
basis/xml/literals/literals-tests.factor | 34 +++++++++
basis/xml/literals/literals.factor | 70 +++++++++++++++++++
8 files changed, 104 insertions(+)
rename {extra => basis}/inverse/authors.txt (100%)
rename {extra => basis}/inverse/inverse-docs.factor (100%)
rename {extra => basis}/inverse/inverse-tests.factor (100%)
rename {extra => basis}/inverse/inverse.factor (100%)
rename {extra => basis}/inverse/summary.txt (100%)
rename {extra => basis}/inverse/tags.txt (100%)
diff --git a/extra/inverse/authors.txt b/basis/inverse/authors.txt
similarity index 100%
rename from extra/inverse/authors.txt
rename to basis/inverse/authors.txt
diff --git a/extra/inverse/inverse-docs.factor b/basis/inverse/inverse-docs.factor
similarity index 100%
rename from extra/inverse/inverse-docs.factor
rename to basis/inverse/inverse-docs.factor
diff --git a/extra/inverse/inverse-tests.factor b/basis/inverse/inverse-tests.factor
similarity index 100%
rename from extra/inverse/inverse-tests.factor
rename to basis/inverse/inverse-tests.factor
diff --git a/extra/inverse/inverse.factor b/basis/inverse/inverse.factor
similarity index 100%
rename from extra/inverse/inverse.factor
rename to basis/inverse/inverse.factor
diff --git a/extra/inverse/summary.txt b/basis/inverse/summary.txt
similarity index 100%
rename from extra/inverse/summary.txt
rename to basis/inverse/summary.txt
diff --git a/extra/inverse/tags.txt b/basis/inverse/tags.txt
similarity index 100%
rename from extra/inverse/tags.txt
rename to basis/inverse/tags.txt
diff --git a/basis/xml/literals/literals-tests.factor b/basis/xml/literals/literals-tests.factor
index ec68a034a6..0d8367c144 100644
--- a/basis/xml/literals/literals-tests.factor
+++ b/basis/xml/literals/literals-tests.factor
@@ -66,3 +66,37 @@ IN: xml.literals.tests
[ 1 ] [ [ <XML <foo/> XML> ] length ] unit-test
[ "" ] [ [XML XML] concat ] unit-test
+
+USE: inverse
+
+[ "foo" ] [ [XML <a>foo</a> XML] [ [XML <a><-></a> XML] ] undo ] unit-test
+[ "foo" ] [ [XML <a bar='foo'/> XML] [ [XML <a bar=<-> /> XML] ] undo ] unit-test
+[ "foo" "baz" ] [ [XML <a bar='foo'>baz</a> XML] [ [XML <a bar=<->><-></a> XML] ] undo ] unit-test
+
+: dispatch ( xml -- string )
+ {
+ { [ [XML <a><-></a> XML] ] [ "a" prepend ] }
+ { [ [XML <b><-></b> XML] ] [ "b" prepend ] }
+ { [ [XML <b val='yes'/> XML] ] [ "byes" ] }
+ { [ [XML <b val=<->/> XML] ] [ "bno" prepend ] }
+ } switch ;
+
+[ "apple" ] [ [XML <a>pple</a> XML] dispatch ] unit-test
+[ "banana" ] [ [XML <b>anana</b> XML] dispatch ] unit-test
+[ "byes" ] [ [XML <b val="yes"/> XML] dispatch ] unit-test
+[ "bnowhere" ] [ [XML <b val="where"/> XML] dispatch ] unit-test
+[ "baboon" ] [ [XML <b val="something">aboon</b> XML] dispatch ] unit-test
+[ "apple" ] [ <XML <a>pple</a> XML> dispatch ] unit-test
+[ "apple" ] [ <XML <a>pple</a> XML> body>> dispatch ] unit-test
+
+: dispatch-doc ( xml -- string )
+ {
+ { [ <XML <a><-></a> XML> ] [ "a" prepend ] }
+ { [ <XML <b><-></b> XML> ] [ "b" prepend ] }
+ { [ <XML <b val='yes'/> XML> ] [ "byes" ] }
+ { [ <XML <b val=<->/> XML> ] [ "bno" prepend ] }
+ } switch ;
+
+[ "apple" ] [ <XML <a>pple</a> XML> dispatch-doc ] unit-test
+[ "apple" ] [ [XML <a>pple</a> XML] dispatch-doc ] unit-test
+[ "apple" ] [ <XML <a>pple</a> XML> body>> dispatch-doc ] unit-test
diff --git a/basis/xml/literals/literals.factor b/basis/xml/literals/literals.factor
index 1520afdde4..4648f7b0e7 100644
--- a/basis/xml/literals/literals.factor
+++ b/basis/xml/literals/literals.factor
@@ -142,3 +142,73 @@ PRIVATE>
: [XML
"XML]" [ string>chunk ] parse-def ; parsing
+
+USING: inverse sorting fry combinators.short-circuit ;
+
+: remove-blanks ( seq -- newseq )
+ [ { [ string? not ] [ [ blank? ] all? not ] } 1|| ] filter ;
+
+GENERIC: >xml ( xml -- tag )
+M: xml >xml body>> ;
+M: tag >xml ;
+M: xml-chunk >xml
+ remove-blanks
+ [ length 1 =/fail ]
+ [ first dup tag? [ fail ] unless ] bi ;
+M: object >xml fail ;
+
+: 1chunk ( object -- xml-chunk )
+ 1array <xml-chunk> ;
+
+GENERIC: >xml-chunk ( xml -- chunk )
+M: xml >xml-chunk body>> 1chunk ;
+M: xml-chunk >xml-chunk ;
+M: object >xml-chunk 1chunk ;
+
+GENERIC: [undo-xml] ( xml -- quot )
+
+M: xml [undo-xml]
+ body>> [undo-xml] '[ >xml @ ] ;
+
+M: xml-chunk [undo-xml]
+ seq>> [undo-xml] '[ >xml-chunk @ ] ;
+
+: undo-attrs ( attrs -- quot: ( attrs -- ) )
+ [
+ [ main>> ] dip dup interpolated?
+ [ var>> '[ _ attr _ set ] ]
+ [ '[ _ attr _ =/fail ] ] if
+ ] { } assoc>map '[ _ cleave ] ;
+
+M: tag [undo-xml] ( tag -- quot: ( tag -- ) )
+ {
+ [ name>> main>> '[ name>> main>> _ =/fail ] ]
+ [ attrs>> undo-attrs ]
+ [ children>> [undo-xml] '[ children>> @ ] ]
+ } cleave '[ _ _ _ tri ] ;
+
+: firstn-strong ( seq n -- ... )
+ [ swap length =/fail ]
+ [ firstn ] 2bi ; inline
+
+M: sequence [undo-xml] ( sequence -- quot: ( seq -- ) )
+ remove-blanks [ length ] [ [ [undo-xml] ] { } map-as ] bi
+ '[ remove-blanks _ firstn-strong _ spread ] ;
+
+M: string [undo-xml] ( string -- quot: ( string -- ) )
+ '[ _ =/fail ] ;
+
+M: xml-data [undo-xml] ( datum -- quot: ( datum -- ) )
+ '[ _ =/fail ] ;
+
+M: interpolated [undo-xml]
+ var>> '[ _ set ] ;
+
+: >enum ( assoc -- enum )
+ ! Assumes keys are 0..n
+ >alist sort-keys values <enum> ;
+
+: undo-xml ( xml -- quot )
+ [undo-xml] '[ H{ } clone [ _ bind ] keep >enum ] ;
+
+\ interpolate-xml 1 [ undo-xml ] define-pop-inverse
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 09/36] 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 8411983f20813316ec11a8bc32ccf2f57c4f12bd Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 5 Feb 2009 14:40:41 -0600
Subject: [PATCH 10/36] fix build-support
---
build-support/factor.sh | 3 ---
1 file changed, 3 deletions(-)
diff --git a/build-support/factor.sh b/build-support/factor.sh
index 36d52601a5..3517d8f4ba 100755
--- a/build-support/factor.sh
+++ b/build-support/factor.sh
@@ -295,9 +295,6 @@ set_build_info() {
elif [[ $OS == winnt && $ARCH == x86 && $WORD == 64 ]] ; then
MAKE_IMAGE_TARGET=winnt-x86.64
MAKE_TARGET=winnt-x86-64
- elif [[ $OS == winnt && $ARCH == x86 && $WORD == 32 ]] ; then
- MAKE_IMAGE_TARGET=winnt-x86.32
- MAKE_TARGET=winnt-x86-32
elif [[ $ARCH == x86 && $WORD == 64 ]] ; then
MAKE_IMAGE_TARGET=unix-x86.64
MAKE_TARGET=$OS-x86-64
From 2466cafbd1f23cbb2c7acd8ef5bb2f4dca980c93 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Thu, 5 Feb 2009 19:04:21 -0600
Subject: [PATCH 11/36] Fixing stack effects of things that use TAGS:
---
basis/xml-rpc/xml-rpc.factor | 2 +-
.../space-file-decoder/space-file-decoder.factor | 12 +++++-------
2 files changed, 6 insertions(+), 8 deletions(-)
diff --git a/basis/xml-rpc/xml-rpc.factor b/basis/xml-rpc/xml-rpc.factor
index 304f7400fa..24dfabc8ff 100644
--- a/basis/xml-rpc/xml-rpc.factor
+++ b/basis/xml-rpc/xml-rpc.factor
@@ -178,5 +178,5 @@ TAG: array xml>item
! This needs to do something in the event of an error
[ send-rpc ] dip http-post nip string>xml receive-rpc ;
-: invoke-method ( params method url -- )
+: invoke-method ( params method url -- response )
[ swap <rpc-method> ] dip post-rpc ;
diff --git a/extra/4DNav/space-file-decoder/space-file-decoder.factor b/extra/4DNav/space-file-decoder/space-file-decoder.factor
index bd3915cb36..ecc8f778fa 100755
--- a/extra/4DNav/space-file-decoder/space-file-decoder.factor
+++ b/extra/4DNav/space-file-decoder/space-file-decoder.factor
@@ -8,7 +8,7 @@ IN: 4DNav.space-file-decoder
: decode-number-array ( x -- y )
"," split [ string>number ] map ;
-TAGS: adsoda-read-model ( tag -- )
+TAGS: adsoda-read-model ( tag -- model )
TAG: dimension adsoda-read-model
children>> first string>number ;
@@ -56,11 +56,9 @@ TAG: space adsoda-read-model
;
: read-model-file ( path -- x )
- dup
- [
- [ file>xml "space" tags-named first adsoda-read-model ]
- [ drop <space> ] recover
- ] [ drop <space> ] if
-
+ [
+ [ file>xml "space" tag-named adsoda-read-model ]
+ [ 2drop <space> ] recover
+ ] [ <space> ] if*
;
From 0dd811557b160666b352f6bf2b5264cae1586919 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Thu, 5 Feb 2009 20:28:36 -0600
Subject: [PATCH 12/36] Removing sequences.next
---
basis/sequences/next/authors.txt | 1 -
basis/sequences/next/next-tests.factor | 5 -----
basis/sequences/next/next.factor | 21 ---------------------
basis/sequences/next/summary.txt | 1 -
basis/sequences/next/tags.txt | 1 -
basis/unicode/case/case.factor | 2 +-
6 files changed, 1 insertion(+), 30 deletions(-)
delete mode 100644 basis/sequences/next/authors.txt
delete mode 100644 basis/sequences/next/next-tests.factor
delete mode 100644 basis/sequences/next/next.factor
delete mode 100644 basis/sequences/next/summary.txt
delete mode 100644 basis/sequences/next/tags.txt
diff --git a/basis/sequences/next/authors.txt b/basis/sequences/next/authors.txt
deleted file mode 100644
index f990dd0ed2..0000000000
--- a/basis/sequences/next/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Daniel Ehrenberg
diff --git a/basis/sequences/next/next-tests.factor b/basis/sequences/next/next-tests.factor
deleted file mode 100644
index be728b2d8e..0000000000
--- a/basis/sequences/next/next-tests.factor
+++ /dev/null
@@ -1,5 +0,0 @@
-USING: sequences.next tools.test arrays kernel math sequences ;
-
-[ { { 1 0 } { 2 1 } { f 2 } } ] [ 3 [ 2array ] map-next ] unit-test
-
-[ 8 ] [ 3 [ 1+ ] map 0 swap [ swap [ + + ] [ drop ] if* ] each-next ] unit-test
diff --git a/basis/sequences/next/next.factor b/basis/sequences/next/next.factor
deleted file mode 100644
index 19b406cc58..0000000000
--- a/basis/sequences/next/next.factor
+++ /dev/null
@@ -1,21 +0,0 @@
-USING: kernel sequences sequences.private math ;
-IN: sequences.next
-
-<PRIVATE
-
-: iterate-seq ( seq quot -- i seq quot )
- [ [ length ] keep ] dip ; inline
-
-: (map-next) ( i seq quot -- )
- ! this uses O(n) more bounds checks than is really necessary
- [ [ [ 1+ ] dip ?nth ] 2keep nth-unsafe ] dip call ; inline
-
-PRIVATE>
-
-: each-next ( seq quot: ( next-elt elt -- ) -- )
- iterate-seq [ (map-next) ] 2curry each-integer ; inline
-
-: map-next ( seq quot: ( next-elt elt -- newelt ) -- newseq )
- over dup length swap new-sequence [
- iterate-seq [ (map-next) ] 2curry
- ] dip [ collect ] keep ; inline
diff --git a/basis/sequences/next/summary.txt b/basis/sequences/next/summary.txt
deleted file mode 100644
index fe5bd315de..0000000000
--- a/basis/sequences/next/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Iteration with access to next element
diff --git a/basis/sequences/next/tags.txt b/basis/sequences/next/tags.txt
deleted file mode 100644
index 42d711b32b..0000000000
--- a/basis/sequences/next/tags.txt
+++ /dev/null
@@ -1 +0,0 @@
-collections
diff --git a/basis/unicode/case/case.factor b/basis/unicode/case/case.factor
index 7566138e11..65fab0ac38 100644
--- a/basis/unicode/case/case.factor
+++ b/basis/unicode/case/case.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: unicode.data sequences sequences.next namespaces
+USING: unicode.data sequences namespaces
sbufs make unicode.syntax unicode.normalize math hints
unicode.categories combinators unicode.syntax assocs
strings splitting kernel accessors unicode.breaks fry locals ;
From 86c3481f12ddd58a162c1d5994bd914a7e500443 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Thu, 5 Feb 2009 21:17:03 -0600
Subject: [PATCH 13/36] Moving XML vocabularies around
---
basis/farkup/farkup-tests.factor | 2 +-
basis/farkup/farkup.factor | 2 +-
basis/furnace/chloe-tags/chloe-tags.factor | 4 +-
basis/help/html/html.factor | 2 +-
basis/html/components/components-docs.factor | 2 +-
basis/html/components/components.factor | 2 +-
basis/html/elements/elements.factor | 2 +-
basis/html/forms/forms.factor | 2 +-
basis/html/html.factor | 4 +-
basis/html/streams/streams.factor | 2 +-
basis/html/templates/chloe/chloe.factor | 2 +-
.../html/templates/chloe/syntax/syntax.factor | 2 +-
basis/html/templates/templates.factor | 2 +-
basis/http/http-tests.factor | 2 +-
basis/http/server/responses/responses.factor | 2 +-
basis/http/server/static/static.factor | 2 +-
basis/lcs/diff2html/diff2html.factor | 2 +-
basis/syndication/syndication.factor | 4 +-
basis/xml-rpc/xml-rpc.factor | 4 +-
basis/xml/data/data-docs.factor | 2 +-
basis/xml/dispatch/dispatch-docs.factor | 25 ---------
basis/xml/dispatch/dispatch-tests.factor | 33 ------------
basis/xml/dispatch/dispatch.factor | 32 -----------
basis/xml/literals/authors.txt | 1 -
basis/xml/literals/summary.txt | 1 -
basis/xml/literals/tags.txt | 2 -
basis/xml/{dispatch => syntax}/authors.txt | 0
basis/xml/{dispatch => syntax}/summary.txt | 0
.../syntax-docs.factor} | 53 +++++++++++++++----
.../syntax-tests.factor} | 48 ++++++++++++++---
.../literals.factor => syntax/syntax.factor} | 47 ++++++++++++----
basis/xml/{dispatch => syntax}/tags.txt | 0
basis/xml/tests/encodings.factor | 2 +-
basis/xml/tests/soap.factor | 2 +-
basis/xml/tests/templating.factor | 2 +-
basis/xml/tests/test.factor | 2 +-
basis/xml/tests/xmltest.factor | 2 +-
.../xml/{utilities => traversal}/authors.txt | 0
basis/xml/traversal/summary.txt | 1 +
basis/xml/{utilities => traversal}/tags.txt | 0
.../traversal-docs.factor} | 8 +--
.../traversal-tests.factor} | 10 ++--
.../traversal.factor} | 13 +----
basis/xml/utilities/summary.txt | 1 -
basis/xml/writer/writer-docs.factor | 4 +-
basis/xml/writer/writer-tests.factor | 2 +-
basis/xml/xml-docs.factor | 4 +-
basis/xmode/code2html/code2html.factor | 2 +-
basis/xmode/loader/loader.factor | 2 +-
basis/xmode/loader/syntax/syntax.factor | 2 +-
basis/xmode/utilities/utilities.factor | 2 +-
.../space-file-decoder.factor | 2 +-
extra/msxml-to-csv/msxml-to-csv.factor | 2 +-
extra/svg/svg-tests.factor | 2 +-
extra/svg/svg.factor | 2 +-
extra/yahoo/yahoo.factor | 2 +-
56 files changed, 174 insertions(+), 187 deletions(-)
delete mode 100644 basis/xml/dispatch/dispatch-docs.factor
delete mode 100644 basis/xml/dispatch/dispatch-tests.factor
delete mode 100644 basis/xml/dispatch/dispatch.factor
delete mode 100644 basis/xml/literals/authors.txt
delete mode 100644 basis/xml/literals/summary.txt
delete mode 100644 basis/xml/literals/tags.txt
rename basis/xml/{dispatch => syntax}/authors.txt (100%)
rename basis/xml/{dispatch => syntax}/summary.txt (100%)
rename basis/xml/{literals/literals-docs.factor => syntax/syntax-docs.factor} (53%)
rename basis/xml/{literals/literals-tests.factor => syntax/syntax-tests.factor} (73%)
rename basis/xml/{literals/literals.factor => syntax/syntax.factor} (83%)
rename basis/xml/{dispatch => syntax}/tags.txt (100%)
rename basis/xml/{utilities => traversal}/authors.txt (100%)
create mode 100644 basis/xml/traversal/summary.txt
rename basis/xml/{utilities => traversal}/tags.txt (100%)
rename basis/xml/{utilities/utilities-docs.factor => traversal/traversal-docs.factor} (91%)
rename basis/xml/{utilities/utilities-tests.factor => traversal/traversal-tests.factor} (73%)
rename basis/xml/{utilities/utilities.factor => traversal/traversal.factor} (86%)
delete mode 100644 basis/xml/utilities/summary.txt
diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor
index 49c4dab0db..60a9f785e6 100644
--- a/basis/farkup/farkup-tests.factor
+++ b/basis/farkup/farkup-tests.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: farkup kernel peg peg.ebnf tools.test namespaces xml
-urls.encoding assocs xml.utilities xml.data ;
+urls.encoding assocs xml.traversal xml.data ;
IN: farkup.tests
relative-link-prefix off
diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor
index bad41296ee..a5951a5080 100755
--- a/basis/farkup/farkup.factor
+++ b/basis/farkup/farkup.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators io
io.streams.string kernel math namespaces peg peg.ebnf
-sequences sequences.deep strings xml.entities xml.literals
+sequences sequences.deep strings xml.entities xml.syntax
vectors splitting xmode.code2html urls.encoding xml.data
xml.writer ;
IN: farkup
diff --git a/basis/furnace/chloe-tags/chloe-tags.factor b/basis/furnace/chloe-tags/chloe-tags.factor
index dd24d8dcde..6024607d37 100644
--- a/basis/furnace/chloe-tags/chloe-tags.factor
+++ b/basis/furnace/chloe-tags/chloe-tags.factor
@@ -7,8 +7,8 @@ xml
xml.data
xml.entities
xml.writer
-xml.utilities
-xml.literals
+xml.traversal
+xml.syntax
html.components
html.elements
html.forms
diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor
index 26fc4e2637..cccf320e44 100644
--- a/basis/help/html/html.factor
+++ b/basis/help/html/html.factor
@@ -5,7 +5,7 @@ io.files io.files.temp io.directories html.streams help kernel
assocs sequences make words accessors arrays help.topics vocabs
tools.vocabs tools.vocabs.browser namespaces prettyprint io
vocabs.loader serialize fry memoize unicode.case math.order
-sorting debugger html xml.literals xml.writer ;
+sorting debugger html xml.syntax xml.writer ;
IN: help.html
: escape-char ( ch -- )
diff --git a/basis/html/components/components-docs.factor b/basis/html/components/components-docs.factor
index ce4bddde6a..b432cc0cc6 100644
--- a/basis/html/components/components-docs.factor
+++ b/basis/html/components/components-docs.factor
@@ -100,6 +100,6 @@ $nl
{ $subsection farkup }
"Creating custom components:"
{ $subsection render* }
-"Custom components can emit HTML using the " { $vocab-link "xml.literals" } " vocabulary." ;
+"Custom components can emit HTML using the " { $vocab-link "xml.syntax" } " vocabulary." ;
ABOUT: "html.components"
diff --git a/basis/html/components/components.factor b/basis/html/components/components.factor
index f811343df2..82bb75015e 100644
--- a/basis/html/components/components.factor
+++ b/basis/html/components/components.factor
@@ -4,7 +4,7 @@ USING: accessors kernel namespaces io math.parser assocs classes
classes.tuple words arrays sequences splitting mirrors
hashtables combinators continuations math strings inspector
fry locals calendar calendar.format xml.entities xml.data
-validators urls present xml.writer xml.literals xml
+validators urls present xml.writer xml.syntax xml
xmode.code2html lcs.diff2html farkup io.streams.string
html html.streams html.forms ;
IN: html.components
diff --git a/basis/html/elements/elements.factor b/basis/html/elements/elements.factor
index e23d929d6d..85df4f7b27 100644
--- a/basis/html/elements/elements.factor
+++ b/basis/html/elements/elements.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io io.styles kernel namespaces prettyprint quotations
sequences strings words xml.entities compiler.units effects
-xml.data xml.literals urls math math.parser combinators
+xml.data urls math math.parser combinators
present fry io.streams.string xml.writer html ;
IN: html.elements
diff --git a/basis/html/forms/forms.factor b/basis/html/forms/forms.factor
index 0a69e2ed70..d5c744beab 100644
--- a/basis/html/forms/forms.factor
+++ b/basis/html/forms/forms.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors strings namespaces assocs hashtables io
mirrors math fry sequences words continuations
-xml.entities xml.writer xml.literals ;
+xml.entities xml.writer xml.syntax ;
IN: html.forms
TUPLE: form errors values validation-failed ;
diff --git a/basis/html/html.factor b/basis/html/html.factor
index 5e86add10e..e86b4917d7 100644
--- a/basis/html/html.factor
+++ b/basis/html/html.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2004, 2009 Chris Double, Daniel Ehrenberg,
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel xml.data xml.writer xml.literals urls.encoding ;
+USING: kernel xml.data xml.writer xml.syntax urls.encoding ;
IN: html
: simple-page ( title head body -- xml )
@@ -21,4 +21,4 @@ IN: html
[XML <span class="error"><-></span> XML] ;
: simple-link ( xml url -- xml' )
- url-encode swap [XML <a href=<->><-></a> XML] ;
\ No newline at end of file
+ url-encode swap [XML <a href=<->><-></a> XML] ;
diff --git a/basis/html/streams/streams.factor b/basis/html/streams/streams.factor
index 0a4b8eddd4..28d6e6d5de 100644
--- a/basis/html/streams/streams.factor
+++ b/basis/html/streams/streams.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel assocs io io.styles math math.order math.parser
-sequences strings make words combinators macros xml.literals html fry
+sequences strings make words combinators macros xml.syntax html fry
destructors ;
IN: html.streams
diff --git a/basis/html/templates/chloe/chloe.factor b/basis/html/templates/chloe/chloe.factor
index e5b40fcfaa..6ab6722afe 100644
--- a/basis/html/templates/chloe/chloe.factor
+++ b/basis/html/templates/chloe/chloe.factor
@@ -5,7 +5,7 @@ namespaces make classes.tuple assocs splitting words arrays io
io.files io.files.info io.encodings.utf8 io.streams.string
unicode.case mirrors math urls present multiline quotations xml
logging continuations
-xml.data xml.writer xml.literals strings
+xml.data xml.writer xml.syntax strings
html.forms
html
html.elements
diff --git a/basis/html/templates/chloe/syntax/syntax.factor b/basis/html/templates/chloe/syntax/syntax.factor
index c2ecd4506b..f149c3fe47 100644
--- a/basis/html/templates/chloe/syntax/syntax.factor
+++ b/basis/html/templates/chloe/syntax/syntax.factor
@@ -5,7 +5,7 @@ USING: accessors kernel sequences combinators kernel namespaces
classes.tuple assocs splitting words arrays memoize parser lexer
io io.files io.encodings.utf8 io.streams.string
unicode.case mirrors fry math urls
-multiline xml xml.data xml.writer xml.utilities
+multiline xml xml.data xml.writer xml.syntax
html.components
html.templates ;
diff --git a/basis/html/templates/templates.factor b/basis/html/templates/templates.factor
index efaf8d6a62..4aca73cc57 100644
--- a/basis/html/templates/templates.factor
+++ b/basis/html/templates/templates.factor
@@ -3,7 +3,7 @@
USING: accessors kernel fry io io.encodings.utf8 io.files
debugger prettyprint continuations namespaces boxes sequences
arrays strings html io.streams.string
-quotations xml.data xml.writer xml.literals ;
+quotations xml.data xml.writer xml.syntax ;
IN: html.templates
MIXIN: template
diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor
index f593980467..49acdb639c 100644
--- a/basis/http/http-tests.factor
+++ b/basis/http/http-tests.factor
@@ -299,7 +299,7 @@ test-db [
[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
USING: html.components html.forms
-xml xml.utilities validators
+xml xml.traversal validators
furnace furnace.conversations ;
SYMBOL: a
diff --git a/basis/http/server/responses/responses.factor b/basis/http/server/responses/responses.factor
index c9b4600ac8..3902b7f5e2 100644
--- a/basis/http/server/responses/responses.factor
+++ b/basis/http/server/responses/responses.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: math.parser http accessors kernel xml.literals xml.writer
+USING: math.parser http accessors kernel xml.syntax xml.writer
io io.streams.string io.encodings.utf8 ;
IN: http.server.responses
diff --git a/basis/http/server/static/static.factor b/basis/http/server/static/static.factor
index 2df8838061..53d3d4f917 100644
--- a/basis/http/server/static/static.factor
+++ b/basis/http/server/static/static.factor
@@ -4,7 +4,7 @@ USING: calendar kernel math math.order math.parser namespaces
parser sequences strings assocs hashtables debugger mime.types
sorting logging calendar.format accessors splitting io io.files
io.files.info io.directories io.pathnames io.encodings.binary
-fry xml.entities destructors urls html xml.literals
+fry xml.entities destructors urls html xml.syntax
html.templates.fhtml http http.server http.server.responses
http.server.redirection xml.writer ;
IN: http.server.static
diff --git a/basis/lcs/diff2html/diff2html.factor b/basis/lcs/diff2html/diff2html.factor
index 16e6cc8d97..ca9e48eb05 100644
--- a/basis/lcs/diff2html/diff2html.factor
+++ b/basis/lcs/diff2html/diff2html.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: lcs xml.literals xml.writer kernel strings ;
+USING: lcs xml.syntax xml.writer kernel strings ;
FROM: accessors => item>> ;
FROM: io => write ;
FROM: sequences => each if-empty when-empty map ;
diff --git a/basis/syndication/syndication.factor b/basis/syndication/syndication.factor
index 4cd5ef17b3..9901fd4ce4 100755
--- a/basis/syndication/syndication.factor
+++ b/basis/syndication/syndication.factor
@@ -1,10 +1,10 @@
! Copyright (C) 2006 Chris Double, Daniel Ehrenberg.
! Portions copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: xml.utilities kernel assocs math.order
+USING: xml.traversal kernel assocs math.order
strings sequences xml.data xml.writer
io.streams.string combinators xml xml.entities.html io.files io
- http.client namespaces make xml.literals hashtables
+ http.client namespaces make xml.syntax hashtables
calendar.format accessors continuations urls present ;
IN: syndication
diff --git a/basis/xml-rpc/xml-rpc.factor b/basis/xml-rpc/xml-rpc.factor
index 24dfabc8ff..9632cbb1ac 100644
--- a/basis/xml-rpc/xml-rpc.factor
+++ b/basis/xml-rpc/xml-rpc.factor
@@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel xml arrays math generic http.client
combinators hashtables namespaces io base64 sequences strings
-calendar xml.data xml.writer xml.utilities assocs math.parser
-debugger calendar.format math.order xml.literals xml.dispatch ;
+calendar xml.data xml.writer xml.traversal assocs math.parser
+debugger calendar.format math.order xml.syntax ;
IN: xml-rpc
! * Sending RPC requests
diff --git a/basis/xml/data/data-docs.factor b/basis/xml/data/data-docs.factor
index 639ef5591c..8c837fdf19 100644
--- a/basis/xml/data/data-docs.factor
+++ b/basis/xml/data/data-docs.factor
@@ -10,7 +10,7 @@ ARTICLE: "xml.data" "XML data types"
"Simple words for manipulating names:"
{ $subsection names-match? }
{ $subsection assure-name }
-"For high-level tools for manipulating XML, see " { $vocab-link "xml.utilities" } ;
+"For high-level tools for manipulating XML, see " { $vocab-link "xml.traversal" } ;
ARTICLE: { "xml.data" "classes" } "XML data classes"
"XML documents and chunks are made of the following classes:"
diff --git a/basis/xml/dispatch/dispatch-docs.factor b/basis/xml/dispatch/dispatch-docs.factor
deleted file mode 100644
index d3d24d736c..0000000000
--- a/basis/xml/dispatch/dispatch-docs.factor
+++ /dev/null
@@ -1,25 +0,0 @@
-! Copyright (C) 2005, 2009 Daniel Ehrenberg
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax ;
-IN: xml.dispatch
-
-ABOUT: "xml.dispatch"
-
-ARTICLE: "xml.dispatch" "Dispatch on XML tag names"
-"The " { $link "xml.dispatch" } " vocabulary defines a system, analogous to generic words, for processing XML. A word can dispatch off the name of the tag that is passed to it. To define such a word, use"
-{ $subsection POSTPONE: TAGS: }
-"and to define a new 'method' for this word, use"
-{ $subsection POSTPONE: TAG: } ;
-
-HELP: TAGS:
-{ $syntax "TAGS: word" }
-{ $values { "word" "a new word to define" } }
-{ $description "Creates a new word to which dispatches on XML tag names." }
-{ $see-also POSTPONE: TAG: } ;
-
-HELP: TAG:
-{ $syntax "TAG: tag word definition... ;" }
-{ $values { "tag" "an XML tag name" } { "word" "an XML process" } }
-{ $description "Defines a 'method' on a word created with " { $link POSTPONE: TAGS: } ". It determines what such a word should do for an argument that is has the given name." }
-{ $examples { $code "TAGS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } }
-{ $see-also POSTPONE: TAGS: } ;
diff --git a/basis/xml/dispatch/dispatch-tests.factor b/basis/xml/dispatch/dispatch-tests.factor
deleted file mode 100644
index e76a759291..0000000000
--- a/basis/xml/dispatch/dispatch-tests.factor
+++ /dev/null
@@ -1,33 +0,0 @@
-! Copyright (C) 2005, 2009 Daniel Ehrenberg
-! See http://factorcode.org/license.txt for BSD license.
-USING: xml io kernel math sequences strings xml.utilities
-tools.test math.parser xml.dispatch ;
-IN: xml.dispatch.tests
-
-TAGS: calculate ( tag -- n )
-
-: calc-2children ( tag -- n n )
- children-tags first2 [ calculate ] dip calculate ;
-
-TAG: number calculate
- children>string string>number ;
-TAG: add calculate
- calc-2children + ;
-TAG: minus calculate
- calc-2children - ;
-TAG: times calculate
- calc-2children * ;
-TAG: divide calculate
- calc-2children / ;
-TAG: neg calculate
- children-tags first calculate neg ;
-
-: calc-arith ( string -- n )
- string>xml first-child-tag calculate ;
-
-[ 32 ] [
- "<math><times><add><number>1</number><number>3</number></add><neg><number>-8</number></neg></times></math>"
- calc-arith
-] unit-test
-
-\ calc-arith must-infer
diff --git a/basis/xml/dispatch/dispatch.factor b/basis/xml/dispatch/dispatch.factor
deleted file mode 100644
index af47f7c14c..0000000000
--- a/basis/xml/dispatch/dispatch.factor
+++ /dev/null
@@ -1,32 +0,0 @@
-! Copyright (C) 2005, 2009 Daniel Ehrenberg
-! See http://factorcode.org/license.txt for BSD license.
-USING: words assocs kernel accessors parser sequences summary
-lexer splitting fry combinators locals ;
-IN: xml.dispatch
-
-TUPLE: no-tag name word ;
-M: no-tag summary
- drop "The tag-dispatching word has no method for the given tag name" ;
-
-<PRIVATE
-
-: compile-tags ( word xtable -- quot )
- >alist swap '[ _ no-tag boa throw ] suffix
- '[ dup main>> _ case ] ;
-
-PRIVATE>
-
-: define-tags ( word -- )
- dup dup "xtable" word-prop compile-tags define ;
-
-:: define-tag ( string word quot -- )
- quot string word "xtable" word-prop set-at
- word define-tags ;
-
-: TAGS:
- CREATE
- [ H{ } clone "xtable" set-word-prop ]
- [ define-tags ] bi ; parsing
-
-: TAG:
- scan scan-word parse-definition define-tag ; parsing
diff --git a/basis/xml/literals/authors.txt b/basis/xml/literals/authors.txt
deleted file mode 100644
index 29e79639ae..0000000000
--- a/basis/xml/literals/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Daniel Ehrenberg
\ No newline at end of file
diff --git a/basis/xml/literals/summary.txt b/basis/xml/literals/summary.txt
deleted file mode 100644
index 7c18fc8c76..0000000000
--- a/basis/xml/literals/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Syntax for XML interpolation
diff --git a/basis/xml/literals/tags.txt b/basis/xml/literals/tags.txt
deleted file mode 100644
index d236e9679f..0000000000
--- a/basis/xml/literals/tags.txt
+++ /dev/null
@@ -1,2 +0,0 @@
-syntax
-enterprise
diff --git a/basis/xml/dispatch/authors.txt b/basis/xml/syntax/authors.txt
similarity index 100%
rename from basis/xml/dispatch/authors.txt
rename to basis/xml/syntax/authors.txt
diff --git a/basis/xml/dispatch/summary.txt b/basis/xml/syntax/summary.txt
similarity index 100%
rename from basis/xml/dispatch/summary.txt
rename to basis/xml/syntax/summary.txt
diff --git a/basis/xml/literals/literals-docs.factor b/basis/xml/syntax/syntax-docs.factor
similarity index 53%
rename from basis/xml/literals/literals-docs.factor
rename to basis/xml/syntax/syntax-docs.factor
index a37fcbd711..19f059078b 100644
--- a/basis/xml/literals/literals-docs.factor
+++ b/basis/xml/syntax/syntax-docs.factor
@@ -1,29 +1,56 @@
-USING: help.markup help.syntax present multiline xml.data ;
-IN: xml.literals
+! Copyright (C) 2005, 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax xml.data present multiline ;
+IN: xml.syntax
-ABOUT: "xml.literals"
+ABOUT: "xml.syntax"
-ARTICLE: "xml.literals" "XML literals"
-"The " { $vocab-link "xml.literals" } " vocabulary provides a convenient syntax for generating XML documents and chunks. It defines the following parsing words:"
+ARTICLE: "xml.syntax" "Syntax extensions for XML"
+"The " { $link "xml.syntax" } " vocabulary defines a number of new parsing words forXML processing."
+{ $subsection { "xml.syntax" "tags" } }
+{ $subsection { "xml.syntax" "literals" } }
+{ $subsection POSTPONE: XML-NS: } ;
+
+ARTICLE: { "xml.syntax" "tags" } "Dispatch on XML tag names"
+"There is a system, analogous to generic words, for processing XML. A word can dispatch off the name of the tag that is passed to it. To define such a word, use"
+{ $subsection POSTPONE: TAGS: }
+"and to define a new 'method' for this word, use"
+{ $subsection POSTPONE: TAG: } ;
+
+HELP: TAGS:
+{ $syntax "TAGS: word" }
+{ $values { "word" "a new word to define" } }
+{ $description "Creates a new word to which dispatches on XML tag names." }
+{ $see-also POSTPONE: TAG: } ;
+
+HELP: TAG:
+{ $syntax "TAG: tag word definition... ;" }
+{ $values { "tag" "an XML tag name" } { "word" "an XML process" } }
+{ $description "Defines a 'method' on a word created with " { $link POSTPONE: TAGS: } ". It determines what such a word should do for an argument that is has the given name." }
+{ $examples { $code "TAGS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } }
+{ $see-also POSTPONE: TAGS: } ;
+
+ARTICLE: { "xml.syntax" "literals" } "XML literals"
+"The following words provide syntax for XML literals:"
{ $subsection POSTPONE: <XML }
{ $subsection POSTPONE: [XML }
"These can be used for creating an XML literal, which can be used with variables or a fry-like syntax to interpolate data into XML."
-{ $subsection { "xml.literals" "interpolation" } } ;
+{ $subsection { "xml.syntax" "interpolation" } } ;
HELP: <XML
{ $syntax "<XML <?xml version=\"1.0\"?><document>...</document> XML>" }
-{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML document (" { $link xml } ") on the stack. It can be used for interpolation as well, if interpolation slots are used. For more information about XML interpolation, see " { $link { "xml.literals" "interpolation" } } "." } ;
+{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML document (" { $link xml } ") on the stack. It can be used for interpolation as well, if interpolation slots are used. For more information about XML interpolation, see " { $link { "xml.syntax" "interpolation" } } "." } ;
HELP: [XML
{ $syntax "[XML foo <x>...</x> bar <y>...</y> baz XML]" }
-{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML chunk (" { $link xml-chunk } ") on the stack. For more information about XML interpolation, see " { $link { "xml.literals" "interpolation" } } "." } ;
+{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML chunk (" { $link xml-chunk } ") on the stack. For more information about XML interpolation, see " { $link { "xml.syntax" "interpolation" } } "." } ;
-ARTICLE: { "xml.literals" "interpolation" } "XML interpolation syntax"
+ARTICLE: { "xml.syntax" "interpolation" } "XML interpolation syntax"
"XML interpolation has two forms for each of the words " { $link POSTPONE: <XML } " and " { $link POSTPONE: [XML } ": a fry-like form and a locals form. To splice locals in, use the syntax " { $snippet "<-variable->" } ". To splice something in from the stack, in the style of " { $vocab-link "fry" } ", use the syntax " { $snippet "<->" } ". An XML interpolation form may only use one of these styles."
$nl
"These forms can be used where a tag might go, as in " { $snippet "[XML <foo><-></foo> XML]" } " or where an attribute might go, as in " { $snippet "[XML <foo bar=<->/> XML]" } ". When an attribute is spliced in, it is not included if the value is " { $snippet "f" } " and if the value is not a string, the value is put through " { $link present } ". Here is an example of the fry style of XML interpolation:"
{ $example
-{" USING: splitting sequences xml.writer xml.literals ;
+{" USING: splitting sequences xml.writer xml.syntax ;
"one two three" " " split
[ [XML <item><-></item> XML] ] map
<XML <doc><-></doc> XML> pprint-xml"}
@@ -41,7 +68,7 @@ $nl
</doc>"} }
"Here is an example of the locals version:"
{ $example
-{" USING: locals urls xml.literals xml.writer ;
+{" USING: locals urls xml.syntax xml.writer ;
[let |
number [ 3 ]
false [ f ]
@@ -58,3 +85,7 @@ $nl
XML> pprint-xml ] "}
{" <?xml version="1.0" encoding="UTF-8"?>
<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>"} } ;
+
+HELP: XML-NS:
+{ $syntax "XML-NS: name http://url" }
+{ $description "Defines a new word of the given name which constructs XML names in the namespace of the given URL. The names constructed are memoized." } ;
diff --git a/basis/xml/literals/literals-tests.factor b/basis/xml/syntax/syntax-tests.factor
similarity index 73%
rename from basis/xml/literals/literals-tests.factor
rename to basis/xml/syntax/syntax-tests.factor
index 0d8367c144..10ab961ec0 100644
--- a/basis/xml/literals/literals-tests.factor
+++ b/basis/xml/syntax/syntax-tests.factor
@@ -1,9 +1,45 @@
-! Copyright (C) 2009 Daniel Ehrenberg.
+! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test xml.literals multiline kernel assocs
-sequences accessors xml.writer xml.literals.private
-locals splitting urls xml.data classes ;
-IN: xml.literals.tests
+USING: xml io kernel math sequences strings xml.traversal
+tools.test math.parser xml.syntax xml.data xml.syntax.private
+accessors multiline locals inverse xml.writer splitting classes ;
+IN: xml.syntax.tests
+
+! TAGS test
+
+TAGS: calculate ( tag -- n )
+
+: calc-2children ( tag -- n n )
+ children-tags first2 [ calculate ] dip calculate ;
+
+TAG: number calculate
+ children>string string>number ;
+TAG: add calculate
+ calc-2children + ;
+TAG: minus calculate
+ calc-2children - ;
+TAG: times calculate
+ calc-2children * ;
+TAG: divide calculate
+ calc-2children / ;
+TAG: neg calculate
+ children-tags first calculate neg ;
+
+: calc-arith ( string -- n )
+ string>xml first-child-tag calculate ;
+
+[ 32 ] [
+ "<math><times><add><number>1</number><number>3</number></add><neg><number>-8</number></neg></times></math>"
+ calc-arith
+] unit-test
+
+\ calc-arith must-infer
+
+XML-NS: foo http://blah.com
+
+[ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test
+
+! XML literals
[ "a" "c" { "a" "c" f } ] [
"<?xml version='1.0'?><x><-a-><b val=<-c->/><-></x>"
@@ -47,7 +83,7 @@ IN: xml.literals.tests
[ {" <?xml version="1.0" encoding="UTF-8"?>
<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>"} ]
-[ 3 f URL" http://factorcode.org/" "hello" \ drop
+[ 3 f "http://factorcode.org/" "hello" \ drop
<XML <x number=<-> false=<-> url=<-> string=<-> word=<->/> XML>
pprint-xml>string ] unit-test
diff --git a/basis/xml/literals/literals.factor b/basis/xml/syntax/syntax.factor
similarity index 83%
rename from basis/xml/literals/literals.factor
rename to basis/xml/syntax/syntax.factor
index 4648f7b0e7..8e6bebfe6b 100644
--- a/basis/xml/literals/literals.factor
+++ b/basis/xml/syntax/syntax.factor
@@ -1,11 +1,42 @@
-! Copyright (C) 2009 Daniel Ehrenberg.
+! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: xml xml.state kernel sequences fry assocs xml.data
-accessors strings make multiline parser namespaces macros
-sequences.deep generalizations words combinators
-math present arrays unicode.categories locals.backend
-quotations ;
-IN: xml.literals
+USING: words assocs kernel accessors parser sequences summary
+lexer splitting combinators locals xml.data memoize sequences.deep
+xml.data xml.state xml namespaces present arrays generalizations strings
+make math macros multiline inverse combinators.short-circuit
+sorting fry unicode.categories ;
+IN: xml.syntax
+
+<PRIVATE
+
+TUPLE: no-tag name word ;
+M: no-tag summary
+ drop "The tag-dispatching word has no method for the given tag name" ;
+
+: compile-tags ( word xtable -- quot )
+ >alist swap '[ _ no-tag boa throw ] suffix
+ '[ dup main>> _ case ] ;
+
+: define-tags ( word -- )
+ dup dup "xtable" word-prop compile-tags define ;
+
+:: define-tag ( string word quot -- )
+ quot string word "xtable" word-prop set-at
+ word define-tags ;
+
+PRIVATE>
+
+: TAGS:
+ CREATE
+ [ H{ } clone "xtable" set-word-prop ]
+ [ define-tags ] bi ; parsing
+
+: TAG:
+ scan scan-word parse-definition define-tag ; parsing
+
+: XML-NS:
+ CREATE-WORD (( string -- name )) over set-stack-effect
+ scan '[ f swap _ <name> ] define-memoized ; parsing
<PRIVATE
@@ -143,8 +174,6 @@ PRIVATE>
: [XML
"XML]" [ string>chunk ] parse-def ; parsing
-USING: inverse sorting fry combinators.short-circuit ;
-
: remove-blanks ( seq -- newseq )
[ { [ string? not ] [ [ blank? ] all? not ] } 1|| ] filter ;
diff --git a/basis/xml/dispatch/tags.txt b/basis/xml/syntax/tags.txt
similarity index 100%
rename from basis/xml/dispatch/tags.txt
rename to basis/xml/syntax/tags.txt
diff --git a/basis/xml/tests/encodings.factor b/basis/xml/tests/encodings.factor
index 35076d2930..aec3e40a52 100644
--- a/basis/xml/tests/encodings.factor
+++ b/basis/xml/tests/encodings.factor
@@ -1,4 +1,4 @@
-USING: xml xml.data xml.utilities tools.test accessors kernel
+USING: xml xml.data xml.traversal tools.test accessors kernel
io.encodings.8-bit ;
[ "\u000131" ] [ "resource:basis/xml/tests/latin5.xml" file>xml children>string ] unit-test
diff --git a/basis/xml/tests/soap.factor b/basis/xml/tests/soap.factor
index d2568a24e1..3d1ac2379e 100644
--- a/basis/xml/tests/soap.factor
+++ b/basis/xml/tests/soap.factor
@@ -1,4 +1,4 @@
-USING: sequences xml kernel arrays xml.utilities io.files tools.test ;
+USING: sequences xml kernel arrays xml.traversal io.files tools.test ;
IN: xml.tests
: assemble-data ( tag -- 3array )
diff --git a/basis/xml/tests/templating.factor b/basis/xml/tests/templating.factor
index 618e785d05..4861f86d7b 100644
--- a/basis/xml/tests/templating.factor
+++ b/basis/xml/tests/templating.factor
@@ -1,5 +1,5 @@
USING: kernel xml sequences assocs tools.test io arrays namespaces fry
-accessors xml.data xml.utilities xml.writer generic sequences.deep multiline ;
+accessors xml.data xml.traversal xml.writer generic sequences.deep multiline ;
IN: xml.tests
: sub-tag
diff --git a/basis/xml/tests/test.factor b/basis/xml/tests/test.factor
index dcd428d9e6..b1f6cf002f 100644
--- a/basis/xml/tests/test.factor
+++ b/basis/xml/tests/test.factor
@@ -3,7 +3,7 @@
IN: xml.tests
USING: kernel xml tools.test io namespaces make sequences
xml.errors xml.entities.html parser strings xml.data io.files
-xml.utilities continuations assocs
+xml.traversal continuations assocs
sequences.deep accessors io.streams.string ;
! This is insufficient
diff --git a/basis/xml/tests/xmltest.factor b/basis/xml/tests/xmltest.factor
index a8024ce151..80472fc788 100644
--- a/basis/xml/tests/xmltest.factor
+++ b/basis/xml/tests/xmltest.factor
@@ -1,6 +1,6 @@
USING: accessors assocs combinators continuations fry generalizations
io.pathnames kernel macros sequences stack-checker tools.test xml
-xml.utilities xml.writer arrays xml.data ;
+xml.traversal xml.writer arrays xml.data ;
IN: xml.tests.suite
TUPLE: xml-test id uri sections description type ;
diff --git a/basis/xml/utilities/authors.txt b/basis/xml/traversal/authors.txt
similarity index 100%
rename from basis/xml/utilities/authors.txt
rename to basis/xml/traversal/authors.txt
diff --git a/basis/xml/traversal/summary.txt b/basis/xml/traversal/summary.txt
new file mode 100644
index 0000000000..365ec87864
--- /dev/null
+++ b/basis/xml/traversal/summary.txt
@@ -0,0 +1 @@
+Utilities for traversing an XML DOM tree
diff --git a/basis/xml/utilities/tags.txt b/basis/xml/traversal/tags.txt
similarity index 100%
rename from basis/xml/utilities/tags.txt
rename to basis/xml/traversal/tags.txt
diff --git a/basis/xml/utilities/utilities-docs.factor b/basis/xml/traversal/traversal-docs.factor
similarity index 91%
rename from basis/xml/utilities/utilities-docs.factor
rename to basis/xml/traversal/traversal-docs.factor
index 161ca824c3..1329c4975e 100644
--- a/basis/xml/utilities/utilities-docs.factor
+++ b/basis/xml/traversal/traversal-docs.factor
@@ -1,12 +1,12 @@
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax xml.data sequences strings ;
-IN: xml.utilities
+IN: xml.traversal
-ABOUT: "xml.utilities"
+ABOUT: "xml.traversal"
-ARTICLE: "xml.utilities" "Utilities for processing XML"
- "Getting parts of an XML document or tag:"
+ARTICLE: "xml.traversal" "Utilities for traversing XML"
+ "The " { $vocab-link "xml.traversal" } " vocabulary provides utilities for traversing an XML DOM tree and viewing the contents of a single tag. The following words are defined:"
$nl
"Note: the difference between deep-tag-named and tag-named is that the former searches recursively among all children and children of children of the tag, while the latter only looks at the direct children, and is therefore more efficient."
{ $subsection tag-named }
diff --git a/basis/xml/utilities/utilities-tests.factor b/basis/xml/traversal/traversal-tests.factor
similarity index 73%
rename from basis/xml/utilities/utilities-tests.factor
rename to basis/xml/traversal/traversal-tests.factor
index 673bf47f6e..165ca34adf 100644
--- a/basis/xml/utilities/utilities-tests.factor
+++ b/basis/xml/traversal/traversal-tests.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: xml xml.utilities tools.test xml.data sequences ;
-IN: xml.utilities.tests
+USING: xml xml.traversal tools.test xml.data sequences ;
+IN: xml.traversal.tests
[ "bar" ] [ "<foo>bar</foo>" string>xml children>string ] unit-test
@@ -9,14 +9,10 @@ IN: xml.utilities.tests
[ "" ] [ "<foo/>" string>xml children>string ] unit-test
-XML-NS: foo http://blah.com
-
-[ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test
-
[ "blah" ] [ "<foo attr='blah'/>" string>xml-chunk "foo" deep-tag-named "attr" attr ] unit-test
[ { "blah" } ] [ "<foo attr='blah'/>" string>xml-chunk "foo" deep-tags-named [ "attr" attr ] map ] unit-test
[ "blah" ] [ "<foo attr='blah'/>" string>xml "foo" deep-tag-named "attr" attr ] unit-test
-[ { "blah" } ] [ "<foo attr='blah'/>" string>xml "foo" deep-tags-named [ "attr" attr ] map ] unit-test
\ No newline at end of file
+[ { "blah" } ] [ "<foo attr='blah'/>" string>xml "foo" deep-tags-named [ "attr" attr ] map ] unit-test
diff --git a/basis/xml/utilities/utilities.factor b/basis/xml/traversal/traversal.factor
similarity index 86%
rename from basis/xml/utilities/utilities.factor
rename to basis/xml/traversal/traversal.factor
index 1249da8c36..b337ea1472 100755
--- a/basis/xml/utilities/utilities.factor
+++ b/basis/xml/traversal/traversal.factor
@@ -3,7 +3,7 @@
USING: accessors kernel namespaces sequences words io assocs
quotations strings parser lexer arrays xml.data xml.writer debugger
splitting vectors sequences.deep combinators fry memoize ;
-IN: xml.utilities
+IN: xml.traversal
: children>string ( tag -- string )
children>> {
@@ -66,14 +66,3 @@ PRIVATE>
: assert-tag ( name name -- )
names-match? [ "Unexpected XML tag found" throw ] unless ;
-
-: insert-children ( children tag -- )
- dup children>> [ push-all ]
- [ swap V{ } like >>children drop ] if ;
-
-: insert-child ( child tag -- )
- [ 1vector ] dip insert-children ;
-
-: XML-NS:
- CREATE-WORD (( string -- name )) over set-stack-effect
- scan '[ f swap _ <name> ] define-memoized ; parsing
diff --git a/basis/xml/utilities/summary.txt b/basis/xml/utilities/summary.txt
deleted file mode 100644
index a671132945..0000000000
--- a/basis/xml/utilities/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Utilities for manipulating an XML DOM tree
diff --git a/basis/xml/writer/writer-docs.factor b/basis/xml/writer/writer-docs.factor
index cc45528cec..9971abcdf1 100644
--- a/basis/xml/writer/writer-docs.factor
+++ b/basis/xml/writer/writer-docs.factor
@@ -41,7 +41,7 @@ HELP: pprint-xml
HELP: indenter
{ $var-description "Contains the string which is used for indenting in the XML prettyprinter. For example, to print an XML document using " { $snippet "%%%%" } " for indentation, you can use the following:" }
-{ $example {" USING: xml.literals xml.writer namespaces ;
+{ $example {" USING: xml.syntax xml.writer namespaces ;
[XML <foo>bar</foo> XML] "%%%%" indenter [ pprint-xml ] with-variable "} {"
<foo>
%%%%bar
@@ -49,7 +49,7 @@ HELP: indenter
HELP: sensitive-tags
{ $var-description "Contains a sequence of " { $link name } "s where whitespace should be considered significant for prettyprinting purposes. The sequence can contain " { $link string } "s in place of names. For example, to preserve whitespace inside a " { $snippet "pre" } " tag:" }
-{ $example {" USING: xml.literals xml.writer namespaces ;
+{ $example {" USING: xml.syntax xml.writer namespaces ;
[XML <html> <head> <title> something</title></head><body><pre>bing
bang
bong</pre></body></html> XML] { "pre" } sensitive-tags [ pprint-xml ] with-variable "} {"
diff --git a/basis/xml/writer/writer-tests.factor b/basis/xml/writer/writer-tests.factor
index f414264e11..23fb7a5074 100644
--- a/basis/xml/writer/writer-tests.factor
+++ b/basis/xml/writer/writer-tests.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: xml.data xml.writer tools.test fry xml kernel multiline
-xml.writer.private io.streams.string xml.utilities sequences
+xml.writer.private io.streams.string xml.traversal sequences
io.encodings.utf8 io.files accessors io.directories ;
IN: xml.writer.tests
diff --git a/basis/xml/xml-docs.factor b/basis/xml/xml-docs.factor
index 901fce2dd4..024b086ef9 100644
--- a/basis/xml/xml-docs.factor
+++ b/basis/xml/xml-docs.factor
@@ -93,7 +93,7 @@ ARTICLE: "xml" "XML parser"
{ $vocab-subsection "XML parsing errors" "xml.errors" }
{ $vocab-subsection "XML entities" "xml.entities" }
{ $vocab-subsection "XML data types" "xml.data" }
- { $vocab-subsection "Utilities for processing XML" "xml.utilities" }
- { $vocab-subsection "Dispatch on XML tag names" "xml.dispatch" } ;
+ { $vocab-subsection "Utilities for traversing XML" "xml.traversal" }
+ { $vocab-subsection "Syntax extensions for XML" "xml.syntax" } ;
ABOUT: "xml"
diff --git a/basis/xmode/code2html/code2html.factor b/basis/xmode/code2html/code2html.factor
index 2f35cd6d76..3fb5a532c9 100644
--- a/basis/xmode/code2html/code2html.factor
+++ b/basis/xmode/code2html/code2html.factor
@@ -1,6 +1,6 @@
USING: xmode.tokens xmode.marker xmode.catalog kernel locals
io io.files sequences words io.encodings.utf8
-namespaces xml.entities accessors xml.literals locals xml.writer ;
+namespaces xml.entities accessors xml.syntax locals xml.writer ;
IN: xmode.code2html
: htmlize-tokens ( tokens -- xml )
diff --git a/basis/xmode/loader/loader.factor b/basis/xmode/loader/loader.factor
index b661f4eb3f..70466913a0 100644
--- a/basis/xmode/loader/loader.factor
+++ b/basis/xmode/loader/loader.factor
@@ -1,5 +1,5 @@
USING: xmode.loader.syntax xmode.tokens xmode.rules
-xmode.keyword-map xml.data xml.utilities xml assocs kernel
+xmode.keyword-map xml.data xml.traversal xml assocs kernel
combinators sequences math.parser namespaces parser
xmode.utilities parser-combinators.regexp io.files accessors ;
IN: xmode.loader
diff --git a/basis/xmode/loader/syntax/syntax.factor b/basis/xmode/loader/syntax/syntax.factor
index b546969a37..0e7293da97 100644
--- a/basis/xmode/loader/syntax/syntax.factor
+++ b/basis/xmode/loader/syntax/syntax.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors xmode.tokens xmode.rules xmode.keyword-map
-xml.data xml.utilities xml assocs kernel combinators sequences
+xml.data xml.traversal xml assocs kernel combinators sequences
math.parser namespaces make parser lexer xmode.utilities
parser-combinators.regexp io.files splitting arrays ;
IN: xmode.loader.syntax
diff --git a/basis/xmode/utilities/utilities.factor b/basis/xmode/utilities/utilities.factor
index d6407d8180..2423fb0d86 100644
--- a/basis/xmode/utilities/utilities.factor
+++ b/basis/xmode/utilities/utilities.factor
@@ -1,5 +1,5 @@
USING: accessors sequences assocs kernel quotations namespaces
-xml.data xml.utilities combinators macros parser lexer words fry ;
+xml.data xml.traversal combinators macros parser lexer words fry ;
IN: xmode.utilities
: implies ( x y -- z ) [ not ] dip or ; inline
diff --git a/extra/4DNav/space-file-decoder/space-file-decoder.factor b/extra/4DNav/space-file-decoder/space-file-decoder.factor
index ecc8f778fa..e85830de52 100755
--- a/extra/4DNav/space-file-decoder/space-file-decoder.factor
+++ b/extra/4DNav/space-file-decoder/space-file-decoder.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Jeff Bigot
! See http://factorcode.org/license.txt for BSD license.
-USING: adsoda xml xml.utilities xml.dispatch accessors
+USING: adsoda xml xml.traversal xml.syntax accessors
combinators sequences math.parser kernel splitting values
continuations ;
IN: 4DNav.space-file-decoder
diff --git a/extra/msxml-to-csv/msxml-to-csv.factor b/extra/msxml-to-csv/msxml-to-csv.factor
index 855275efcc..cab28c14ca 100644
--- a/extra/msxml-to-csv/msxml-to-csv.factor
+++ b/extra/msxml-to-csv/msxml-to-csv.factor
@@ -1,4 +1,4 @@
-USING: io io.files sequences xml xml.utilities
+USING: io io.files sequences xml xml.traversal
io.encodings.ascii kernel ;
IN: msxml-to-csv
diff --git a/extra/svg/svg-tests.factor b/extra/svg/svg-tests.factor
index 3a28310d71..0f0c349b8e 100644
--- a/extra/svg/svg-tests.factor
+++ b/extra/svg/svg-tests.factor
@@ -1,6 +1,6 @@
! (c)2009 Joe Groff, see BSD license
USING: accessors arrays literals math math.affine-transforms
-math.functions multiline sequences svg tools.test xml xml.utilities ;
+math.functions multiline sequences svg tools.test xml xml.traversal ;
IN: svg.tests
{ 1.0 2.25 } { -3.0 4.0 } { 5.5 0.000001 } <affine-transform> 1array [
diff --git a/extra/svg/svg.factor b/extra/svg/svg.factor
index 4d8a6e6a17..2ed5d21707 100644
--- a/extra/svg/svg.factor
+++ b/extra/svg/svg.factor
@@ -1,7 +1,7 @@
! (c)2009 Joe Groff, see BSD license
USING: accessors arrays assocs fry kernel math math.affine-transforms math.constants
math.functions math.parser math.vectors memoize peg.ebnf sequences sequences.squish
-splitting strings xml.data xml.utilities ;
+splitting strings xml.data xml.syntax ;
IN: svg
XML-NS: svg-name http://www.w3.org/2000/svg
diff --git a/extra/yahoo/yahoo.factor b/extra/yahoo/yahoo.factor
index d163c8f1ac..b58a11747f 100755
--- a/extra/yahoo/yahoo.factor
+++ b/extra/yahoo/yahoo.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2006 Daniel Ehrenberg, Walton Chan
! See http://factorcode.org/license.txt for BSD license.
-USING: http.client xml xml.utilities kernel sequences
+USING: http.client xml xml.traversal kernel sequences
math.parser urls accessors locals ;
IN: yahoo
From 51b5973b0e356392462aa1385a36e8925dafb863 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Thu, 5 Feb 2009 21:26:40 -0600
Subject: [PATCH 14/36] Documenting XML interpolation inverse
---
basis/xml/syntax/syntax-docs.factor | 12 +++++++++++-
1 file changed, 11 insertions(+), 1 deletion(-)
diff --git a/basis/xml/syntax/syntax-docs.factor b/basis/xml/syntax/syntax-docs.factor
index 19f059078b..34473fecfc 100644
--- a/basis/xml/syntax/syntax-docs.factor
+++ b/basis/xml/syntax/syntax-docs.factor
@@ -84,7 +84,17 @@ $nl
word=<-word-> />
XML> pprint-xml ] "}
{" <?xml version="1.0" encoding="UTF-8"?>
-<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>"} } ;
+<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>"} }
+"XML interpolation can also be used, in conjunction with " { $vocab-link "inverse" } " in pattern matching. For example:"
+{ $example {" USING: sequences xml.syntax inverse ;
+: dispatch ( xml -- string )
+ {
+ { [ [XML <a><-></a> XML] ] [ "a" prepend ] }
+ { [ [XML <b><-></b> XML] ] [ "b" prepend ] }
+ { [ [XML <b val='yes'/> XML] ] [ "yes" ] }
+ { [ [XML <b val=<->/> XML] ] [ "no" prepend ] }
+ } switch ;
+[XML <a>pple</a> XML] dispatch write "} "apple" } ;
HELP: XML-NS:
{ $syntax "XML-NS: name http://url" }
From 67ffc894021de130614cb9d0425d6c8c8681ce62 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 5 Feb 2009 22:19:52 -0600
Subject: [PATCH 15/36] colors.constants: defines a COLOR: word which looks up
colors in X11 rgb.txt
---
basis/colors/constants/authors.txt | 1 +
basis/colors/constants/constants-tests.factor | 6 +
basis/colors/constants/constants.factor | 31 +
basis/colors/constants/rgb.txt | 753 ++++++++++++++++++
basis/colors/constants/summary.txt | 1 +
5 files changed, 792 insertions(+)
create mode 100644 basis/colors/constants/authors.txt
create mode 100644 basis/colors/constants/constants-tests.factor
create mode 100644 basis/colors/constants/constants.factor
create mode 100644 basis/colors/constants/rgb.txt
create mode 100644 basis/colors/constants/summary.txt
diff --git a/basis/colors/constants/authors.txt b/basis/colors/constants/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/colors/constants/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/colors/constants/constants-tests.factor b/basis/colors/constants/constants-tests.factor
new file mode 100644
index 0000000000..08b05a34e7
--- /dev/null
+++ b/basis/colors/constants/constants-tests.factor
@@ -0,0 +1,6 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test colors.constants colors ;
+IN: colors.constants.tests
+
+[ t ] [ COLOR: light-green rgba? ] unit-test
\ No newline at end of file
diff --git a/basis/colors/constants/constants.factor b/basis/colors/constants/constants.factor
new file mode 100644
index 0000000000..e298b3b61e
--- /dev/null
+++ b/basis/colors/constants/constants.factor
@@ -0,0 +1,31 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel assocs math math.parser memoize
+io.encodings.ascii io.files lexer parser
+colors sequences splitting combinators.smart ascii ;
+IN: colors.constants
+
+<PRIVATE
+
+: parse-color ( line -- name color )
+ [
+ [ [ string>number 255 /f ] tri@ 1.0 <rgba> ] dip
+ [ blank? ] trim-head { { CHAR: \s CHAR: - } } substitute swap
+ ] input<sequence ;
+
+: parse-rgb.txt ( lines -- assoc )
+ [ "!" head? not ] filter
+ [ 11 cut [ " \t" split harvest ] dip suffix ] map
+ [ parse-color ] H{ } map>assoc ;
+
+MEMO: rgb.txt ( -- assoc )
+ "resource:basis/colors/constants/rgb.txt" ascii file-lines parse-rgb.txt ;
+
+PRIVATE>
+
+ERROR: no-such-color name ;
+
+: named-color ( name -- rgb )
+ dup rgb.txt at [ ] [ no-such-color ] ?if ;
+
+: COLOR: scan named-color parsed ; parsing
\ No newline at end of file
diff --git a/basis/colors/constants/rgb.txt b/basis/colors/constants/rgb.txt
new file mode 100644
index 0000000000..62eb8961ec
--- /dev/null
+++ b/basis/colors/constants/rgb.txt
@@ -0,0 +1,753 @@
+! $Xorg: rgb.txt,v 1.3 2000/08/17 19:54:00 cpqbld Exp $
+255 250 250 snow
+248 248 255 ghost white
+248 248 255 GhostWhite
+245 245 245 white smoke
+245 245 245 WhiteSmoke
+220 220 220 gainsboro
+255 250 240 floral white
+255 250 240 FloralWhite
+253 245 230 old lace
+253 245 230 OldLace
+250 240 230 linen
+250 235 215 antique white
+250 235 215 AntiqueWhite
+255 239 213 papaya whip
+255 239 213 PapayaWhip
+255 235 205 blanched almond
+255 235 205 BlanchedAlmond
+255 228 196 bisque
+255 218 185 peach puff
+255 218 185 PeachPuff
+255 222 173 navajo white
+255 222 173 NavajoWhite
+255 228 181 moccasin
+255 248 220 cornsilk
+255 255 240 ivory
+255 250 205 lemon chiffon
+255 250 205 LemonChiffon
+255 245 238 seashell
+240 255 240 honeydew
+245 255 250 mint cream
+245 255 250 MintCream
+240 255 255 azure
+240 248 255 alice blue
+240 248 255 AliceBlue
+230 230 250 lavender
+255 240 245 lavender blush
+255 240 245 LavenderBlush
+255 228 225 misty rose
+255 228 225 MistyRose
+255 255 255 white
+ 0 0 0 black
+ 47 79 79 dark slate gray
+ 47 79 79 DarkSlateGray
+ 47 79 79 dark slate grey
+ 47 79 79 DarkSlateGrey
+105 105 105 dim gray
+105 105 105 DimGray
+105 105 105 dim grey
+105 105 105 DimGrey
+112 128 144 slate gray
+112 128 144 SlateGray
+112 128 144 slate grey
+112 128 144 SlateGrey
+119 136 153 light slate gray
+119 136 153 LightSlateGray
+119 136 153 light slate grey
+119 136 153 LightSlateGrey
+190 190 190 gray
+190 190 190 grey
+211 211 211 light grey
+211 211 211 LightGrey
+211 211 211 light gray
+211 211 211 LightGray
+ 25 25 112 midnight blue
+ 25 25 112 MidnightBlue
+ 0 0 128 navy
+ 0 0 128 navy blue
+ 0 0 128 NavyBlue
+100 149 237 cornflower blue
+100 149 237 CornflowerBlue
+ 72 61 139 dark slate blue
+ 72 61 139 DarkSlateBlue
+106 90 205 slate blue
+106 90 205 SlateBlue
+123 104 238 medium slate blue
+123 104 238 MediumSlateBlue
+132 112 255 light slate blue
+132 112 255 LightSlateBlue
+ 0 0 205 medium blue
+ 0 0 205 MediumBlue
+ 65 105 225 royal blue
+ 65 105 225 RoyalBlue
+ 0 0 255 blue
+ 30 144 255 dodger blue
+ 30 144 255 DodgerBlue
+ 0 191 255 deep sky blue
+ 0 191 255 DeepSkyBlue
+135 206 235 sky blue
+135 206 235 SkyBlue
+135 206 250 light sky blue
+135 206 250 LightSkyBlue
+ 70 130 180 steel blue
+ 70 130 180 SteelBlue
+176 196 222 light steel blue
+176 196 222 LightSteelBlue
+173 216 230 light blue
+173 216 230 LightBlue
+176 224 230 powder blue
+176 224 230 PowderBlue
+175 238 238 pale turquoise
+175 238 238 PaleTurquoise
+ 0 206 209 dark turquoise
+ 0 206 209 DarkTurquoise
+ 72 209 204 medium turquoise
+ 72 209 204 MediumTurquoise
+ 64 224 208 turquoise
+ 0 255 255 cyan
+224 255 255 light cyan
+224 255 255 LightCyan
+ 95 158 160 cadet blue
+ 95 158 160 CadetBlue
+102 205 170 medium aquamarine
+102 205 170 MediumAquamarine
+127 255 212 aquamarine
+ 0 100 0 dark green
+ 0 100 0 DarkGreen
+ 85 107 47 dark olive green
+ 85 107 47 DarkOliveGreen
+143 188 143 dark sea green
+143 188 143 DarkSeaGreen
+ 46 139 87 sea green
+ 46 139 87 SeaGreen
+ 60 179 113 medium sea green
+ 60 179 113 MediumSeaGreen
+ 32 178 170 light sea green
+ 32 178 170 LightSeaGreen
+152 251 152 pale green
+152 251 152 PaleGreen
+ 0 255 127 spring green
+ 0 255 127 SpringGreen
+124 252 0 lawn green
+124 252 0 LawnGreen
+ 0 255 0 green
+127 255 0 chartreuse
+ 0 250 154 medium spring green
+ 0 250 154 MediumSpringGreen
+173 255 47 green yellow
+173 255 47 GreenYellow
+ 50 205 50 lime green
+ 50 205 50 LimeGreen
+154 205 50 yellow green
+154 205 50 YellowGreen
+ 34 139 34 forest green
+ 34 139 34 ForestGreen
+107 142 35 olive drab
+107 142 35 OliveDrab
+189 183 107 dark khaki
+189 183 107 DarkKhaki
+240 230 140 khaki
+238 232 170 pale goldenrod
+238 232 170 PaleGoldenrod
+250 250 210 light goldenrod yellow
+250 250 210 LightGoldenrodYellow
+255 255 224 light yellow
+255 255 224 LightYellow
+255 255 0 yellow
+255 215 0 gold
+238 221 130 light goldenrod
+238 221 130 LightGoldenrod
+218 165 32 goldenrod
+184 134 11 dark goldenrod
+184 134 11 DarkGoldenrod
+188 143 143 rosy brown
+188 143 143 RosyBrown
+205 92 92 indian red
+205 92 92 IndianRed
+139 69 19 saddle brown
+139 69 19 SaddleBrown
+160 82 45 sienna
+205 133 63 peru
+222 184 135 burlywood
+245 245 220 beige
+245 222 179 wheat
+244 164 96 sandy brown
+244 164 96 SandyBrown
+210 180 140 tan
+210 105 30 chocolate
+178 34 34 firebrick
+165 42 42 brown
+233 150 122 dark salmon
+233 150 122 DarkSalmon
+250 128 114 salmon
+255 160 122 light salmon
+255 160 122 LightSalmon
+255 165 0 orange
+255 140 0 dark orange
+255 140 0 DarkOrange
+255 127 80 coral
+240 128 128 light coral
+240 128 128 LightCoral
+255 99 71 tomato
+255 69 0 orange red
+255 69 0 OrangeRed
+255 0 0 red
+255 105 180 hot pink
+255 105 180 HotPink
+255 20 147 deep pink
+255 20 147 DeepPink
+255 192 203 pink
+255 182 193 light pink
+255 182 193 LightPink
+219 112 147 pale violet red
+219 112 147 PaleVioletRed
+176 48 96 maroon
+199 21 133 medium violet red
+199 21 133 MediumVioletRed
+208 32 144 violet red
+208 32 144 VioletRed
+255 0 255 magenta
+238 130 238 violet
+221 160 221 plum
+218 112 214 orchid
+186 85 211 medium orchid
+186 85 211 MediumOrchid
+153 50 204 dark orchid
+153 50 204 DarkOrchid
+148 0 211 dark violet
+148 0 211 DarkViolet
+138 43 226 blue violet
+138 43 226 BlueViolet
+160 32 240 purple
+147 112 219 medium purple
+147 112 219 MediumPurple
+216 191 216 thistle
+255 250 250 snow1
+238 233 233 snow2
+205 201 201 snow3
+139 137 137 snow4
+255 245 238 seashell1
+238 229 222 seashell2
+205 197 191 seashell3
+139 134 130 seashell4
+255 239 219 AntiqueWhite1
+238 223 204 AntiqueWhite2
+205 192 176 AntiqueWhite3
+139 131 120 AntiqueWhite4
+255 228 196 bisque1
+238 213 183 bisque2
+205 183 158 bisque3
+139 125 107 bisque4
+255 218 185 PeachPuff1
+238 203 173 PeachPuff2
+205 175 149 PeachPuff3
+139 119 101 PeachPuff4
+255 222 173 NavajoWhite1
+238 207 161 NavajoWhite2
+205 179 139 NavajoWhite3
+139 121 94 NavajoWhite4
+255 250 205 LemonChiffon1
+238 233 191 LemonChiffon2
+205 201 165 LemonChiffon3
+139 137 112 LemonChiffon4
+255 248 220 cornsilk1
+238 232 205 cornsilk2
+205 200 177 cornsilk3
+139 136 120 cornsilk4
+255 255 240 ivory1
+238 238 224 ivory2
+205 205 193 ivory3
+139 139 131 ivory4
+240 255 240 honeydew1
+224 238 224 honeydew2
+193 205 193 honeydew3
+131 139 131 honeydew4
+255 240 245 LavenderBlush1
+238 224 229 LavenderBlush2
+205 193 197 LavenderBlush3
+139 131 134 LavenderBlush4
+255 228 225 MistyRose1
+238 213 210 MistyRose2
+205 183 181 MistyRose3
+139 125 123 MistyRose4
+240 255 255 azure1
+224 238 238 azure2
+193 205 205 azure3
+131 139 139 azure4
+131 111 255 SlateBlue1
+122 103 238 SlateBlue2
+105 89 205 SlateBlue3
+ 71 60 139 SlateBlue4
+ 72 118 255 RoyalBlue1
+ 67 110 238 RoyalBlue2
+ 58 95 205 RoyalBlue3
+ 39 64 139 RoyalBlue4
+ 0 0 255 blue1
+ 0 0 238 blue2
+ 0 0 205 blue3
+ 0 0 139 blue4
+ 30 144 255 DodgerBlue1
+ 28 134 238 DodgerBlue2
+ 24 116 205 DodgerBlue3
+ 16 78 139 DodgerBlue4
+ 99 184 255 SteelBlue1
+ 92 172 238 SteelBlue2
+ 79 148 205 SteelBlue3
+ 54 100 139 SteelBlue4
+ 0 191 255 DeepSkyBlue1
+ 0 178 238 DeepSkyBlue2
+ 0 154 205 DeepSkyBlue3
+ 0 104 139 DeepSkyBlue4
+135 206 255 SkyBlue1
+126 192 238 SkyBlue2
+108 166 205 SkyBlue3
+ 74 112 139 SkyBlue4
+176 226 255 LightSkyBlue1
+164 211 238 LightSkyBlue2
+141 182 205 LightSkyBlue3
+ 96 123 139 LightSkyBlue4
+198 226 255 SlateGray1
+185 211 238 SlateGray2
+159 182 205 SlateGray3
+108 123 139 SlateGray4
+202 225 255 LightSteelBlue1
+188 210 238 LightSteelBlue2
+162 181 205 LightSteelBlue3
+110 123 139 LightSteelBlue4
+191 239 255 LightBlue1
+178 223 238 LightBlue2
+154 192 205 LightBlue3
+104 131 139 LightBlue4
+224 255 255 LightCyan1
+209 238 238 LightCyan2
+180 205 205 LightCyan3
+122 139 139 LightCyan4
+187 255 255 PaleTurquoise1
+174 238 238 PaleTurquoise2
+150 205 205 PaleTurquoise3
+102 139 139 PaleTurquoise4
+152 245 255 CadetBlue1
+142 229 238 CadetBlue2
+122 197 205 CadetBlue3
+ 83 134 139 CadetBlue4
+ 0 245 255 turquoise1
+ 0 229 238 turquoise2
+ 0 197 205 turquoise3
+ 0 134 139 turquoise4
+ 0 255 255 cyan1
+ 0 238 238 cyan2
+ 0 205 205 cyan3
+ 0 139 139 cyan4
+151 255 255 DarkSlateGray1
+141 238 238 DarkSlateGray2
+121 205 205 DarkSlateGray3
+ 82 139 139 DarkSlateGray4
+127 255 212 aquamarine1
+118 238 198 aquamarine2
+102 205 170 aquamarine3
+ 69 139 116 aquamarine4
+193 255 193 DarkSeaGreen1
+180 238 180 DarkSeaGreen2
+155 205 155 DarkSeaGreen3
+105 139 105 DarkSeaGreen4
+ 84 255 159 SeaGreen1
+ 78 238 148 SeaGreen2
+ 67 205 128 SeaGreen3
+ 46 139 87 SeaGreen4
+154 255 154 PaleGreen1
+144 238 144 PaleGreen2
+124 205 124 PaleGreen3
+ 84 139 84 PaleGreen4
+ 0 255 127 SpringGreen1
+ 0 238 118 SpringGreen2
+ 0 205 102 SpringGreen3
+ 0 139 69 SpringGreen4
+ 0 255 0 green1
+ 0 238 0 green2
+ 0 205 0 green3
+ 0 139 0 green4
+127 255 0 chartreuse1
+118 238 0 chartreuse2
+102 205 0 chartreuse3
+ 69 139 0 chartreuse4
+192 255 62 OliveDrab1
+179 238 58 OliveDrab2
+154 205 50 OliveDrab3
+105 139 34 OliveDrab4
+202 255 112 DarkOliveGreen1
+188 238 104 DarkOliveGreen2
+162 205 90 DarkOliveGreen3
+110 139 61 DarkOliveGreen4
+255 246 143 khaki1
+238 230 133 khaki2
+205 198 115 khaki3
+139 134 78 khaki4
+255 236 139 LightGoldenrod1
+238 220 130 LightGoldenrod2
+205 190 112 LightGoldenrod3
+139 129 76 LightGoldenrod4
+255 255 224 LightYellow1
+238 238 209 LightYellow2
+205 205 180 LightYellow3
+139 139 122 LightYellow4
+255 255 0 yellow1
+238 238 0 yellow2
+205 205 0 yellow3
+139 139 0 yellow4
+255 215 0 gold1
+238 201 0 gold2
+205 173 0 gold3
+139 117 0 gold4
+255 193 37 goldenrod1
+238 180 34 goldenrod2
+205 155 29 goldenrod3
+139 105 20 goldenrod4
+255 185 15 DarkGoldenrod1
+238 173 14 DarkGoldenrod2
+205 149 12 DarkGoldenrod3
+139 101 8 DarkGoldenrod4
+255 193 193 RosyBrown1
+238 180 180 RosyBrown2
+205 155 155 RosyBrown3
+139 105 105 RosyBrown4
+255 106 106 IndianRed1
+238 99 99 IndianRed2
+205 85 85 IndianRed3
+139 58 58 IndianRed4
+255 130 71 sienna1
+238 121 66 sienna2
+205 104 57 sienna3
+139 71 38 sienna4
+255 211 155 burlywood1
+238 197 145 burlywood2
+205 170 125 burlywood3
+139 115 85 burlywood4
+255 231 186 wheat1
+238 216 174 wheat2
+205 186 150 wheat3
+139 126 102 wheat4
+255 165 79 tan1
+238 154 73 tan2
+205 133 63 tan3
+139 90 43 tan4
+255 127 36 chocolate1
+238 118 33 chocolate2
+205 102 29 chocolate3
+139 69 19 chocolate4
+255 48 48 firebrick1
+238 44 44 firebrick2
+205 38 38 firebrick3
+139 26 26 firebrick4
+255 64 64 brown1
+238 59 59 brown2
+205 51 51 brown3
+139 35 35 brown4
+255 140 105 salmon1
+238 130 98 salmon2
+205 112 84 salmon3
+139 76 57 salmon4
+255 160 122 LightSalmon1
+238 149 114 LightSalmon2
+205 129 98 LightSalmon3
+139 87 66 LightSalmon4
+255 165 0 orange1
+238 154 0 orange2
+205 133 0 orange3
+139 90 0 orange4
+255 127 0 DarkOrange1
+238 118 0 DarkOrange2
+205 102 0 DarkOrange3
+139 69 0 DarkOrange4
+255 114 86 coral1
+238 106 80 coral2
+205 91 69 coral3
+139 62 47 coral4
+255 99 71 tomato1
+238 92 66 tomato2
+205 79 57 tomato3
+139 54 38 tomato4
+255 69 0 OrangeRed1
+238 64 0 OrangeRed2
+205 55 0 OrangeRed3
+139 37 0 OrangeRed4
+255 0 0 red1
+238 0 0 red2
+205 0 0 red3
+139 0 0 red4
+255 20 147 DeepPink1
+238 18 137 DeepPink2
+205 16 118 DeepPink3
+139 10 80 DeepPink4
+255 110 180 HotPink1
+238 106 167 HotPink2
+205 96 144 HotPink3
+139 58 98 HotPink4
+255 181 197 pink1
+238 169 184 pink2
+205 145 158 pink3
+139 99 108 pink4
+255 174 185 LightPink1
+238 162 173 LightPink2
+205 140 149 LightPink3
+139 95 101 LightPink4
+255 130 171 PaleVioletRed1
+238 121 159 PaleVioletRed2
+205 104 137 PaleVioletRed3
+139 71 93 PaleVioletRed4
+255 52 179 maroon1
+238 48 167 maroon2
+205 41 144 maroon3
+139 28 98 maroon4
+255 62 150 VioletRed1
+238 58 140 VioletRed2
+205 50 120 VioletRed3
+139 34 82 VioletRed4
+255 0 255 magenta1
+238 0 238 magenta2
+205 0 205 magenta3
+139 0 139 magenta4
+255 131 250 orchid1
+238 122 233 orchid2
+205 105 201 orchid3
+139 71 137 orchid4
+255 187 255 plum1
+238 174 238 plum2
+205 150 205 plum3
+139 102 139 plum4
+224 102 255 MediumOrchid1
+209 95 238 MediumOrchid2
+180 82 205 MediumOrchid3
+122 55 139 MediumOrchid4
+191 62 255 DarkOrchid1
+178 58 238 DarkOrchid2
+154 50 205 DarkOrchid3
+104 34 139 DarkOrchid4
+155 48 255 purple1
+145 44 238 purple2
+125 38 205 purple3
+ 85 26 139 purple4
+171 130 255 MediumPurple1
+159 121 238 MediumPurple2
+137 104 205 MediumPurple3
+ 93 71 139 MediumPurple4
+255 225 255 thistle1
+238 210 238 thistle2
+205 181 205 thistle3
+139 123 139 thistle4
+ 0 0 0 gray0
+ 0 0 0 grey0
+ 3 3 3 gray1
+ 3 3 3 grey1
+ 5 5 5 gray2
+ 5 5 5 grey2
+ 8 8 8 gray3
+ 8 8 8 grey3
+ 10 10 10 gray4
+ 10 10 10 grey4
+ 13 13 13 gray5
+ 13 13 13 grey5
+ 15 15 15 gray6
+ 15 15 15 grey6
+ 18 18 18 gray7
+ 18 18 18 grey7
+ 20 20 20 gray8
+ 20 20 20 grey8
+ 23 23 23 gray9
+ 23 23 23 grey9
+ 26 26 26 gray10
+ 26 26 26 grey10
+ 28 28 28 gray11
+ 28 28 28 grey11
+ 31 31 31 gray12
+ 31 31 31 grey12
+ 33 33 33 gray13
+ 33 33 33 grey13
+ 36 36 36 gray14
+ 36 36 36 grey14
+ 38 38 38 gray15
+ 38 38 38 grey15
+ 41 41 41 gray16
+ 41 41 41 grey16
+ 43 43 43 gray17
+ 43 43 43 grey17
+ 46 46 46 gray18
+ 46 46 46 grey18
+ 48 48 48 gray19
+ 48 48 48 grey19
+ 51 51 51 gray20
+ 51 51 51 grey20
+ 54 54 54 gray21
+ 54 54 54 grey21
+ 56 56 56 gray22
+ 56 56 56 grey22
+ 59 59 59 gray23
+ 59 59 59 grey23
+ 61 61 61 gray24
+ 61 61 61 grey24
+ 64 64 64 gray25
+ 64 64 64 grey25
+ 66 66 66 gray26
+ 66 66 66 grey26
+ 69 69 69 gray27
+ 69 69 69 grey27
+ 71 71 71 gray28
+ 71 71 71 grey28
+ 74 74 74 gray29
+ 74 74 74 grey29
+ 77 77 77 gray30
+ 77 77 77 grey30
+ 79 79 79 gray31
+ 79 79 79 grey31
+ 82 82 82 gray32
+ 82 82 82 grey32
+ 84 84 84 gray33
+ 84 84 84 grey33
+ 87 87 87 gray34
+ 87 87 87 grey34
+ 89 89 89 gray35
+ 89 89 89 grey35
+ 92 92 92 gray36
+ 92 92 92 grey36
+ 94 94 94 gray37
+ 94 94 94 grey37
+ 97 97 97 gray38
+ 97 97 97 grey38
+ 99 99 99 gray39
+ 99 99 99 grey39
+102 102 102 gray40
+102 102 102 grey40
+105 105 105 gray41
+105 105 105 grey41
+107 107 107 gray42
+107 107 107 grey42
+110 110 110 gray43
+110 110 110 grey43
+112 112 112 gray44
+112 112 112 grey44
+115 115 115 gray45
+115 115 115 grey45
+117 117 117 gray46
+117 117 117 grey46
+120 120 120 gray47
+120 120 120 grey47
+122 122 122 gray48
+122 122 122 grey48
+125 125 125 gray49
+125 125 125 grey49
+127 127 127 gray50
+127 127 127 grey50
+130 130 130 gray51
+130 130 130 grey51
+133 133 133 gray52
+133 133 133 grey52
+135 135 135 gray53
+135 135 135 grey53
+138 138 138 gray54
+138 138 138 grey54
+140 140 140 gray55
+140 140 140 grey55
+143 143 143 gray56
+143 143 143 grey56
+145 145 145 gray57
+145 145 145 grey57
+148 148 148 gray58
+148 148 148 grey58
+150 150 150 gray59
+150 150 150 grey59
+153 153 153 gray60
+153 153 153 grey60
+156 156 156 gray61
+156 156 156 grey61
+158 158 158 gray62
+158 158 158 grey62
+161 161 161 gray63
+161 161 161 grey63
+163 163 163 gray64
+163 163 163 grey64
+166 166 166 gray65
+166 166 166 grey65
+168 168 168 gray66
+168 168 168 grey66
+171 171 171 gray67
+171 171 171 grey67
+173 173 173 gray68
+173 173 173 grey68
+176 176 176 gray69
+176 176 176 grey69
+179 179 179 gray70
+179 179 179 grey70
+181 181 181 gray71
+181 181 181 grey71
+184 184 184 gray72
+184 184 184 grey72
+186 186 186 gray73
+186 186 186 grey73
+189 189 189 gray74
+189 189 189 grey74
+191 191 191 gray75
+191 191 191 grey75
+194 194 194 gray76
+194 194 194 grey76
+196 196 196 gray77
+196 196 196 grey77
+199 199 199 gray78
+199 199 199 grey78
+201 201 201 gray79
+201 201 201 grey79
+204 204 204 gray80
+204 204 204 grey80
+207 207 207 gray81
+207 207 207 grey81
+209 209 209 gray82
+209 209 209 grey82
+212 212 212 gray83
+212 212 212 grey83
+214 214 214 gray84
+214 214 214 grey84
+217 217 217 gray85
+217 217 217 grey85
+219 219 219 gray86
+219 219 219 grey86
+222 222 222 gray87
+222 222 222 grey87
+224 224 224 gray88
+224 224 224 grey88
+227 227 227 gray89
+227 227 227 grey89
+229 229 229 gray90
+229 229 229 grey90
+232 232 232 gray91
+232 232 232 grey91
+235 235 235 gray92
+235 235 235 grey92
+237 237 237 gray93
+237 237 237 grey93
+240 240 240 gray94
+240 240 240 grey94
+242 242 242 gray95
+242 242 242 grey95
+245 245 245 gray96
+245 245 245 grey96
+247 247 247 gray97
+247 247 247 grey97
+250 250 250 gray98
+250 250 250 grey98
+252 252 252 gray99
+252 252 252 grey99
+255 255 255 gray100
+255 255 255 grey100
+169 169 169 dark grey
+169 169 169 DarkGrey
+169 169 169 dark gray
+169 169 169 DarkGray
+0 0 139 dark blue
+0 0 139 DarkBlue
+0 139 139 dark cyan
+0 139 139 DarkCyan
+139 0 139 dark magenta
+139 0 139 DarkMagenta
+139 0 0 dark red
+139 0 0 DarkRed
+144 238 144 light green
+144 238 144 LightGreen
diff --git a/basis/colors/constants/summary.txt b/basis/colors/constants/summary.txt
new file mode 100644
index 0000000000..5551048750
--- /dev/null
+++ b/basis/colors/constants/summary.txt
@@ -0,0 +1 @@
+A utility to look up colors in the X11 rgb.txt color database
From a1f4f7772f988f7fd0cf84598a378747807acb01 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 5 Feb 2009 23:59:36 -0600
Subject: [PATCH 16/36] make multipart work with sessions
---
basis/mime/multipart/multipart.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/mime/multipart/multipart.factor b/basis/mime/multipart/multipart.factor
index fc3024bd01..eda7849a73 100755
--- a/basis/mime/multipart/multipart.factor
+++ b/basis/mime/multipart/multipart.factor
@@ -99,7 +99,7 @@ ERROR: end-of-stream multipart ;
dup name>> empty-name? [
drop
] [
- [ [ header>> ] [ name>> unquote ] [ name-content>> ] tri mime-variable boa ]
+ [ name-content>> ]
[ name>> unquote ]
[ mime-parts>> set-at ] tri
] if ;
From f31e19a66669c1c280858755a3a483eededd7490 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 6 Feb 2009 00:01:28 -0600
Subject: [PATCH 17/36] refactoring graphics.bitmap
---
extra/graphics/bitmap/bitmap-tests.factor | 15 +++
extra/graphics/bitmap/bitmap.factor | 155 +++++++++-------------
extra/graphics/viewer/viewer.factor | 33 ++++-
3 files changed, 108 insertions(+), 95 deletions(-)
create mode 100644 extra/graphics/bitmap/bitmap-tests.factor
diff --git a/extra/graphics/bitmap/bitmap-tests.factor b/extra/graphics/bitmap/bitmap-tests.factor
new file mode 100644
index 0000000000..4998427b22
--- /dev/null
+++ b/extra/graphics/bitmap/bitmap-tests.factor
@@ -0,0 +1,15 @@
+USING: graphics.bitmap ;
+IN: graphics.bitmap.tests
+
+: test-bitmap24 ( -- )
+ "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" bitmap. ;
+
+: test-bitmap8 ( -- )
+ "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" bitmap. ;
+
+: test-bitmap4 ( -- )
+ "resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" bitmap. ;
+
+: test-bitmap1 ( -- )
+ "resource:extra/graphics/bitmap/test-images/1bit.bmp" bitmap. ;
+
diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor
index a0212e47de..bd34a9ee41 100755
--- a/extra/graphics/bitmap/bitmap.factor
+++ b/extra/graphics/bitmap/bitmap.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays byte-arrays combinators summary
-graphics.viewer io io.binary io.files kernel libc math
+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 ;
@@ -12,10 +12,11 @@ IN: graphics.bitmap
! Handles row-reversed bitmaps (their height is negative)
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 array ;
+height planes bit-count compression size-image
+x-pels y-pels color-used color-important rgb-quads color-index
+array ;
-: (array-copy) ( bitmap array -- bitmap array' )
+: array-copy ( bitmap array -- bitmap array' )
over size-image>> abs memory>byte-array ;
MACRO: (nbits>bitmap) ( bits -- )
@@ -24,7 +25,7 @@ MACRO: (nbits>bitmap) ( bits -- )
2over * _ * >>size-image
swap >>height
swap >>width
- swap (array-copy) [ >>array ] [ >>color-index ] bi
+ swap array-copy [ >>array ] [ >>color-index ] bi
_ >>bit-count
] ;
@@ -45,7 +46,7 @@ MACRO: (nbits>bitmap) ( bits -- )
: raw-bitmap>array ( bitmap -- array )
dup bit-count>>
{
- { 32 [ "32bit" throw ] }
+ { 32 [ color-index>> ] }
{ 24 [ color-index>> ] }
{ 16 [ "16bit" throw ] }
{ 8 [ 8bit>array ] }
@@ -59,107 +60,75 @@ ERROR: bitmap-magic ;
M: bitmap-magic summary
drop "First two bytes of bitmap stream must be 'BM'" ;
-: parse-file-header ( bitmap -- )
- 2 read >string dup "BM" = [ bitmap-magic ] unless >>magic
- 4 read le> >>size
- 4 read le> >>reserved
- 4 read le> >>offset drop ;
+: read2 ( -- n ) 2 read le> ;
+: read4 ( -- n ) 4 read le> ;
-: parse-bitmap-header ( bitmap -- )
- 4 read le> >>header-length
- 4 read signed-le> >>width
- 4 read signed-le> >>height
- 2 read le> >>planes
- 2 read le> >>bit-count
- 4 read le> >>compression
- 4 read le> >>size-image
- 4 read le> >>x-pels
- 4 read le> >>y-pels
- 4 read le> >>color-used
- 4 read le> >>color-important drop ;
+: parse-file-header ( bitmap -- bitmap )
+ 2 read >string dup "BM" = [ bitmap-magic ] unless >>magic
+ read4 >>size
+ read4 >>reserved
+ read4 >>offset ;
+
+: parse-bitmap-header ( bitmap -- bitmap )
+ read4 >>header-length
+ read4 >>width
+ read4 >>height
+ read2 >>planes
+ read2 >>bit-count
+ read4 >>compression
+ read4 >>size-image
+ read4 >>x-pels
+ read4 >>y-pels
+ read4 >>color-used
+ read4 >>color-important ;
: rgb-quads-length ( bitmap -- n )
- [ offset>> 14 - ] keep header-length>> - ;
+ [ offset>> 14 - ] [ header-length>> ] bi - ;
: color-index-length ( bitmap -- n )
- [ width>> ] keep [ planes>> * ] keep
- [ bit-count>> * 31 + 32 /i 4 * ] keep
- height>> abs * ;
+ {
+ [ width>> ]
+ [ planes>> * ]
+ [ bit-count>> * 31 + 32 /i 4 * ]
+ [ height>> abs * ]
+ } cleave ;
-: parse-bitmap ( bitmap -- )
+: parse-bitmap ( bitmap -- bitmap )
dup rgb-quads-length read >>rgb-quads
- dup color-index-length read >>color-index drop ;
+ dup color-index-length read >>color-index ;
: load-bitmap ( path -- bitmap )
binary [
bitmap new
- dup parse-file-header
- dup parse-bitmap-header
- dup parse-bitmap
+ parse-file-header parse-bitmap-header parse-bitmap
] with-file-reader
dup raw-bitmap>array >>array ;
+: write2 ( n -- ) 2 >le write ;
+: write4 ( n -- ) 4 >le write ;
+
: save-bitmap ( bitmap path -- )
binary [
- "BM" >byte-array write
- dup array>> length 14 + 40 + 4 >le write
- 0 4 >le write
- 54 4 >le write
-
- 40 4 >le write
- {
- [ width>> 4 >le write ]
- [ height>> 4 >le write ]
- [ planes>> 1 or 2 >le write ]
- [ bit-count>> 24 or 2 >le write ]
- [ compression>> 0 or 4 >le write ]
- [ size-image>> 4 >le write ]
- [ x-pels>> 0 or 4 >le write ]
- [ y-pels>> 0 or 4 >le write ]
- [ color-used>> 0 or 4 >le write ]
- [ color-important>> 0 or 4 >le write ]
- [ rgb-quads>> write ]
- [ color-index>> write ]
- } cleave
+ B{ CHAR: B CHAR: M } write
+ [
+ array>> length 14 + 40 + write4
+ 0 write4
+ 54 write4
+ 40 write4
+ ] [
+ {
+ [ width>> write4 ]
+ [ height>> write4 ]
+ [ planes>> 1 or write2 ]
+ [ bit-count>> 24 or write2 ]
+ [ compression>> 0 or write4 ]
+ [ size-image>> write4 ]
+ [ x-pels>> 0 or write4 ]
+ [ y-pels>> 0 or write4 ]
+ [ color-used>> 0 or write4 ]
+ [ color-important>> 0 or write4 ]
+ [ rgb-quads>> write ]
+ [ color-index>> write ]
+ } cleave
+ ] bi
] with-file-writer ;
-
-M: bitmap draw-image ( bitmap -- )
- dup height>> 0 < [
- 0 0 glRasterPos2i
- 1.0 -1.0 glPixelZoom
- ] [
- 0 over height>> abs glRasterPos2i
- 1.0 1.0 glPixelZoom
- ] if
- [ width>> ] keep
- [
- [ height>> abs ] keep
- bit-count>> {
- { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] }
- { 24 [ GL_BGR GL_UNSIGNED_BYTE ] }
- { 8 [ GL_BGR GL_UNSIGNED_BYTE ] }
- { 4 [ GL_BGR GL_UNSIGNED_BYTE ] }
- } case
- ] keep array>> glDrawPixels ;
-
-M: bitmap width ( bitmap -- ) width>> ;
-M: bitmap height ( bitmap -- ) height>> ;
-
-: bitmap. ( path -- )
- load-bitmap <graphics-gadget> gadget. ;
-
-: bitmap-window ( path -- gadget )
- load-bitmap <graphics-gadget> [ "bitmap" open-window ] keep ;
-
-: test-bitmap24 ( -- )
- "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" bitmap. ;
-
-: test-bitmap8 ( -- )
- "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" bitmap. ;
-
-: test-bitmap4 ( -- )
- "resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" bitmap. ;
-
-: test-bitmap1 ( -- )
- "resource:extra/graphics/bitmap/test-images/1bit.bmp" bitmap. ;
-
diff --git a/extra/graphics/viewer/viewer.factor b/extra/graphics/viewer/viewer.factor
index 0533ffaf5d..8e0b1ec43c 100644
--- a/extra/graphics/viewer/viewer.factor
+++ b/extra/graphics/viewer/viewer.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.functions namespaces opengl
-ui.gadgets ui.render accessors ;
+USING: accessors arrays combinators graphics.bitmap kernel math
+math.functions namespaces opengl opengl.gl ui ui.gadgets
+ui.gadgets.panes ui.render ;
IN: graphics.viewer
TUPLE: graphics-gadget < gadget image ;
@@ -19,3 +20,31 @@ M: graphics-gadget draw-gadget* ( gadget -- )
: <graphics-gadget> ( bitmap -- gadget )
\ graphics-gadget new-gadget
swap >>image ;
+
+M: bitmap draw-image ( bitmap -- )
+ dup height>> 0 < [
+ 0 0 glRasterPos2i
+ 1.0 -1.0 glPixelZoom
+ ] [
+ 0 over height>> abs glRasterPos2i
+ 1.0 1.0 glPixelZoom
+ ] if
+ [ width>> ] keep
+ [
+ [ height>> abs ] keep
+ bit-count>> {
+ { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] }
+ { 24 [ GL_BGR GL_UNSIGNED_BYTE ] }
+ { 8 [ GL_BGR GL_UNSIGNED_BYTE ] }
+ { 4 [ GL_BGR GL_UNSIGNED_BYTE ] }
+ } case
+ ] keep array>> glDrawPixels ;
+
+M: bitmap width ( bitmap -- ) width>> ;
+M: bitmap height ( bitmap -- ) height>> ;
+
+: bitmap. ( path -- )
+ load-bitmap <graphics-gadget> gadget. ;
+
+: bitmap-window ( path -- gadget )
+ load-bitmap <graphics-gadget> [ "bitmap" open-window ] keep ;
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 18/36] 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 4adef7db09688f341283c2081b87faa0cd4b40da Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 6 Feb 2009 02:45:21 -0600
Subject: [PATCH 19/36] Fix functors bug where changing a hand-written method
into one generated by a functor would forget the method; also associate
functor-generated methods with the source file they're in. Add DEFINES-CLASS,
to parallel DEFINES. Update math.blas and specialized-arrays/vectors to use
DEFINES-CLASS where appropriate
---
basis/functors/functors-tests.factor | 51 +++++++++++++++++--
basis/functors/functors.factor | 11 ++--
basis/math/blas/matrices/matrices.factor | 2 +-
basis/math/blas/vectors/vectors.factor | 2 +-
.../direct/functor/functor.factor | 2 +-
.../specialized-arrays/functor/functor.factor | 2 +-
.../functor/functor.factor | 2 +-
7 files changed, 60 insertions(+), 12 deletions(-)
diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor
index a5f3042b38..df008d52bd 100644
--- a/basis/functors/functors-tests.factor
+++ b/basis/functors/functors-tests.factor
@@ -1,11 +1,12 @@
IN: functors.tests
-USING: functors tools.test math words kernel ;
+USING: functors tools.test math words kernel multiline parser
+io.streams.string generic ;
<<
FUNCTOR: define-box ( T -- )
-B DEFINES ${T}-box
+B DEFINES-CLASS ${T}-box
<B> DEFINES <${B}>
WHERE
@@ -62,4 +63,48 @@ WHERE
>>
-[ 4 ] [ 1 3 blah ] unit-test
\ No newline at end of file
+[ 4 ] [ 1 3 blah ] unit-test
+
+GENERIC: some-generic ( a -- b )
+
+! Does replacing an ordinary word with a functor-generated one work?
+[ [ ] ] [
+ <" IN: functors.tests
+
+ TUPLE: some-tuple ;
+ : some-word ( -- ) ;
+ M: some-tuple some-generic ;
+ "> <string-reader> "functors-test" parse-stream
+] unit-test
+
+: test-redefinition ( -- )
+ [ t ] [ "some-word" "functors.tests" lookup >boolean ] unit-test
+ [ t ] [ "some-tuple" "functors.tests" lookup >boolean ] unit-test
+ [ t ] [
+ "some-tuple" "functors.tests" lookup
+ "some-generic" "functors.tests" lookup method >boolean
+ ] unit-test ;
+
+test-redefinition
+
+FUNCTOR: redefine-test ( W -- )
+
+W-word DEFINES ${W}-word
+W-tuple DEFINES-CLASS ${W}-tuple
+W-generic IS ${W}-generic
+
+WHERE
+
+TUPLE: W-tuple ;
+: W-word ( -- ) ;
+M: W-tuple W-generic ;
+
+;FUNCTOR
+
+[ [ ] ] [
+ <" IN: functors.tests
+ << "some" redefine-test >>
+ "> <string-reader> "functors-test" parse-stream
+] unit-test
+
+test-redefinition
\ No newline at end of file
diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor
index f4d35b6932..14151692f0 100644
--- a/basis/functors/functors.factor
+++ b/basis/functors/functors.factor
@@ -3,8 +3,9 @@
USING: kernel quotations classes.tuple make combinators generic
words interpolate namespaces sequences io.streams.string fry
classes.mixin effects lexer parser classes.tuple.parser
-effects.parser locals.types locals.parser
-locals.rewrite.closures vocabs.parser arrays accessors ;
+effects.parser locals.types locals.parser generic.parser
+locals.rewrite.closures vocabs.parser classes.parser
+arrays accessors ;
IN: functors
! This is a hack
@@ -29,7 +30,7 @@ M: object >fake-quotations ;
GENERIC: fake-quotations> ( fake -- quot )
M: fake-quotation fake-quotations>
- seq>> [ fake-quotations> ] map >quotation ;
+ seq>> [ fake-quotations> ] [ ] map-as ;
M: array fake-quotations> [ fake-quotations> ] map ;
@@ -57,7 +58,7 @@ M: object fake-quotations> ;
effect off
scan-param parsed
scan-param parsed
- \ create-method parsed
+ \ create-method-in parsed
parse-definition*
DEFINE* ; parsing
@@ -96,6 +97,8 @@ PRIVATE>
: DEFINES [ create-in ] (INTERPOLATE) ; parsing
+: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ; parsing
+
DEFER: ;FUNCTOR delimiter
<PRIVATE
diff --git a/basis/math/blas/matrices/matrices.factor b/basis/math/blas/matrices/matrices.factor
index 7b03ddf42a..d9653fca6f 100755
--- a/basis/math/blas/matrices/matrices.factor
+++ b/basis/math/blas/matrices/matrices.factor
@@ -256,7 +256,7 @@ XGEMM IS cblas_${T}gemm
XGERU IS cblas_${T}ger${U}
XGERC IS cblas_${T}ger${C}
-MATRIX DEFINES ${TYPE}-blas-matrix
+MATRIX DEFINES-CLASS ${TYPE}-blas-matrix
<MATRIX> DEFINES <${TYPE}-blas-matrix>
>MATRIX DEFINES >${TYPE}-blas-matrix
XMATRIX{ DEFINES ${T}matrix{
diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor
index 3b7f89f730..4e61f4478e 100755
--- a/basis/math/blas/vectors/vectors.factor
+++ b/basis/math/blas/vectors/vectors.factor
@@ -134,7 +134,7 @@ XCOPY IS cblas_${T}copy
XSWAP IS cblas_${T}swap
IXAMAX IS cblas_i${T}amax
-VECTOR DEFINES ${TYPE}-blas-vector
+VECTOR DEFINES-CLASS ${TYPE}-blas-vector
<VECTOR> DEFINES <${TYPE}-blas-vector>
>VECTOR DEFINES >${TYPE}-blas-vector
diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor
index ce23186fc6..0c3999db44 100755
--- a/basis/specialized-arrays/direct/functor/functor.factor
+++ b/basis/specialized-arrays/direct/functor/functor.factor
@@ -11,7 +11,7 @@ A' IS ${T}-array
>A' IS >${T}-array
<A'> IS <${A'}>
-A DEFINES direct-${T}-array
+A DEFINES-CLASS direct-${T}-array
<A> DEFINES <${A}>
NTH [ T dup c-getter array-accessor ]
diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor
index 9a56346be4..3c2c53db31 100644
--- a/basis/specialized-arrays/functor/functor.factor
+++ b/basis/specialized-arrays/functor/functor.factor
@@ -15,7 +15,7 @@ M: bad-byte-array-length summary
FUNCTOR: define-array ( T -- )
-A DEFINES ${T}-array
+A DEFINES-CLASS ${T}-array
<A> DEFINES <${A}>
(A) DEFINES (${A})
>A DEFINES >${A}
diff --git a/basis/specialized-vectors/functor/functor.factor b/basis/specialized-vectors/functor/functor.factor
index 2410cc284e..9d48a9e79e 100644
--- a/basis/specialized-vectors/functor/functor.factor
+++ b/basis/specialized-vectors/functor/functor.factor
@@ -9,7 +9,7 @@ FUNCTOR: define-vector ( T -- )
A IS ${T}-array
<A> IS <${A}>
-V DEFINES ${T}-vector
+V DEFINES-CLASS ${T}-vector
<V> DEFINES <${V}>
>V DEFINES >${V}
V{ DEFINES ${V}{
From 7bb0e78314e21b1094cbbc3aaa1cd766f5100e0e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 6 Feb 2009 04:02:00 -0600
Subject: [PATCH 20/36] Add support for C99 complex float and complex double
types to FFI They are named complex-float and complex-double in the Factor
world
---
basis/alien/arrays/arrays.factor | 17 ++++++++---------
basis/alien/c-types/c-types-docs.factor | 2 ++
basis/alien/structs/structs.factor | 11 +++++++++--
basis/compiler/codegen/codegen.factor | 4 ++--
basis/compiler/tests/alien.factor | 7 +++++++
vm/ffi_test.c | 6 +++++-
vm/ffi_test.h | 2 ++
vm/master.h | 1 +
8 files changed, 36 insertions(+), 14 deletions(-)
diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor
index 727492edb1..c823b614d9 100644
--- a/basis/alien/arrays/arrays.factor
+++ b/basis/alien/arrays/arrays.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays alien.c-types alien.structs
-sequences math kernel namespaces make libc cpu.architecture ;
+sequences math kernel namespaces fry libc cpu.architecture ;
IN: alien.arrays
UNION: value-type array struct-type ;
@@ -10,7 +10,7 @@ M: array c-type ;
M: array c-type-class drop object ;
-M: array heap-size unclip heap-size [ * ] reduce ;
+M: array heap-size unclip [ product ] [ heap-size ] bi* * ;
M: array c-type-align first c-type-align ;
@@ -26,16 +26,15 @@ M: array box-return drop "void*" box-return ;
M: array stack-size drop "void*" stack-size ;
+M: array c-type-boxer-quot drop f ;
+
+M: array c-type-unboxer-quot drop f ;
+
M: value-type c-type-reg-class drop int-regs ;
-M: value-type c-type-boxer-quot drop f ;
-
-M: value-type c-type-unboxer-quot drop f ;
-
M: value-type c-type-getter
drop [ swap <displaced-alien> ] ;
M: value-type c-type-setter ( type -- quot )
- [
- dup c-type-getter % \ swap , heap-size , \ memcpy ,
- ] [ ] make ;
+ [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
+ '[ @ swap @ _ memcpy ] ;
diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor
index a2b555b057..dc29ea9bb3 100644
--- a/basis/alien/c-types/c-types-docs.factor
+++ b/basis/alien/c-types/c-types-docs.factor
@@ -178,6 +178,8 @@ $nl
{ { $snippet "ulonglong" } { } }
{ { $snippet "float" } { } }
{ { $snippet "double" } { "same format as " { $link float } " objects" } }
+ { { $snippet "complex-float" } { "C99 " { $snippet "complex float" } " type, converted to and from " { $link complex } " values" } }
+ { { $snippet "complex-double" } { "C99 " { $snippet "complex double" } " type, converted to and from " { $link complex } " values" } }
}
"When making alien calls, Factor numbers are converted to and from the above types in a canonical way. Converting a Factor number to a C value may result in a loss of precision."
$nl
diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor
index 42923fb28b..d9ed53d0c6 100644
--- a/basis/alien/structs/structs.factor
+++ b/basis/alien/structs/structs.factor
@@ -5,7 +5,7 @@ math namespaces parser sequences strings words libc fry
alien.c-types alien.structs.fields cpu.architecture math.order ;
IN: alien.structs
-TUPLE: struct-type size align fields ;
+TUPLE: struct-type size align fields boxer-quot unboxer-quot getter setter ;
M: struct-type heap-size size>> ;
@@ -15,6 +15,10 @@ M: struct-type c-type-align align>> ;
M: struct-type c-type-stack-align? drop f ;
+M: struct-type c-type-boxer-quot boxer-quot>> ;
+
+M: struct-type c-type-unboxer-quot unboxer-quot>> ;
+
: if-value-struct ( ctype true false -- )
[ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline
@@ -40,7 +44,10 @@ M: struct-type stack-size
: (define-struct) ( name size align fields -- )
[ [ align ] keep ] dip
- struct-type boa
+ struct-type new
+ swap >>fields
+ swap >>align
+ swap >>size
swap typedef ;
: make-fields ( name vocab fields -- fields )
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 71d9c36412..d915b29ae5 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -3,8 +3,8 @@
USING: namespaces make math math.order math.parser sequences accessors
kernel kernel.private layouts assocs words summary arrays
combinators classes.algebra alien alien.c-types alien.structs
-alien.strings alien.arrays sets libc continuations.private
-fry cpu.architecture
+alien.strings alien.arrays alien.complex sets libc
+continuations.private fry cpu.architecture
compiler.errors
compiler.alien
compiler.cfg
diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor
index 1b21e40bac..b1a9853d55 100644
--- a/basis/compiler/tests/alien.factor
+++ b/basis/compiler/tests/alien.factor
@@ -558,3 +558,10 @@ FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
: stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ;
[ ] [ stack-frame-bustage 2drop ] unit-test
+
+FUNCTION: complex-float ffi_test_45 ( 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
diff --git a/vm/ffi_test.c b/vm/ffi_test.c
index 1ec41ac2b9..36147795d1 100755
--- a/vm/ffi_test.c
+++ b/vm/ffi_test.c
@@ -1,6 +1,5 @@
/* This file is linked into the runtime for the sole purpose
* of testing FFI code. */
-#include <stdio.h>
#include "master.h"
#include "ffi_test.h"
@@ -303,3 +302,8 @@ struct test_struct_14 ffi_test_44(void)
retval.x2 = 2.0;
return retval;
}
+
+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 7c51261157..de48d6dc5b 100755
--- a/vm/ffi_test.h
+++ b/vm/ffi_test.h
@@ -88,3 +88,5 @@ struct test_struct_16 { float x; int a; };
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);
diff --git a/vm/master.h b/vm/master.h
index 86b5223eaa..01b2335841 100644
--- a/vm/master.h
+++ b/vm/master.h
@@ -8,6 +8,7 @@
#include <fcntl.h>
#include <limits.h>
#include <math.h>
+#include <complex.h>
#include <stdbool.h>
#include <setjmp.h>
From 7ffbbb13e0ffc533ab7086966cbca975f4f2866d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 6 Feb 2009 04:36:17 -0600
Subject: [PATCH 21/36] Specialized arrays can now be passed to alien functions
directly, without calling underlying>> first
---
basis/alien/arrays/arrays.factor | 2 +-
basis/alien/c-types/c-types.factor | 9 +++++----
core/alien/alien.factor | 10 +++++++++-
3 files changed, 15 insertions(+), 6 deletions(-)
diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor
index c823b614d9..8253d9458c 100644
--- a/basis/alien/arrays/arrays.factor
+++ b/basis/alien/arrays/arrays.factor
@@ -28,7 +28,7 @@ M: array stack-size drop "void*" stack-size ;
M: array c-type-boxer-quot drop f ;
-M: array c-type-unboxer-quot drop f ;
+M: array c-type-unboxer-quot drop [ >c-ptr ] ;
M: value-type c-type-reg-class drop int-regs ;
diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor
index d1354cb04e..ff9d4cefc4 100644
--- a/basis/alien/c-types/c-types.factor
+++ b/basis/alien/c-types/c-types.factor
@@ -201,13 +201,13 @@ M: byte-array byte-length length ;
1 swap malloc-array ; inline
: malloc-byte-array ( byte-array -- alien )
- dup length [ nip malloc dup ] 2keep memcpy ;
+ dup byte-length [ nip malloc dup ] 2keep memcpy ;
: memory>byte-array ( alien len -- byte-array )
[ nip (byte-array) dup ] 2keep memcpy ;
: byte-array>memory ( byte-array base -- )
- swap dup length memcpy ;
+ swap dup byte-length memcpy ;
: array-accessor ( type quot -- def )
[
@@ -263,7 +263,7 @@ M: long-long-type box-return ( type -- )
] when ;
: malloc-file-contents ( path -- alien len )
- binary file-contents dup malloc-byte-array swap length ;
+ binary file-contents [ malloc-byte-array ] [ length ] bi ;
: if-void ( type true false -- )
pick "void" = [ drop nip call ] [ nip call ] if ; inline
@@ -283,9 +283,10 @@ M: long-long-type box-return ( type -- )
<c-type>
c-ptr >>class
[ alien-cell ] >>getter
- [ set-alien-cell ] >>setter
+ [ [ >c-ptr ] 2dip set-alien-cell ] >>setter
bootstrap-cell >>size
bootstrap-cell >>align
+ [ >c-ptr ] >>unboxer-quot
"box_alien" >>boxer
"alien_offset" >>unboxer
"void*" define-primitive-type
diff --git a/core/alien/alien.factor b/core/alien/alien.factor
index c97e36e889..93d1a8e306 100644
--- a/core/alien/alien.factor
+++ b/core/alien/alien.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel math namespaces sequences system
kernel.private byte-arrays arrays init ;
@@ -18,6 +18,14 @@ PREDICATE: pinned-alien < alien underlying>> pinned-c-ptr? ;
UNION: pinned-c-ptr
pinned-alien POSTPONE: f ;
+GENERIC: >c-ptr ( obj -- c-ptr )
+
+M: c-ptr >c-ptr ;
+
+SLOT: underlying
+
+M: object >c-ptr underlying>> ;
+
GENERIC: expired? ( c-ptr -- ? ) flushable
M: alien expired? expired>> ;
From d6aa376ed089ce44364ba47693ab32c7f60c9e28 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 6 Feb 2009 04:37:28 -0600
Subject: [PATCH 22/36] Removing now-redundant underlying>> calls
---
basis/cocoa/messages/messages.factor | 2 +-
basis/cocoa/views/views.factor | 2 +-
basis/compiler/tests/alien.factor | 4 ++--
basis/db/postgresql/lib/lib.factor | 6 +++---
basis/io/backend/unix/multiplexers/epoll/epoll.factor | 2 +-
.../io/backend/unix/multiplexers/kqueue/kqueue.factor | 2 +-
.../io/backend/unix/multiplexers/select/select.factor | 4 ++--
basis/io/launcher/windows/windows.factor | 4 ++--
basis/io/pipes/unix/unix.factor | 2 +-
basis/libc/libc.factor | 4 ++--
basis/opengl/opengl.factor | 10 +++++-----
basis/opengl/shaders/shaders.factor | 2 +-
.../specialized-arrays/specialized-arrays-tests.factor | 7 ++++++-
basis/struct-arrays/struct-arrays-tests.factor | 4 ++--
basis/unix/utilities/utilities.factor | 4 ++--
basis/windows/com/wrapper/wrapper.factor | 2 +-
basis/windows/dinput/constants/constants.factor | 2 +-
basis/x11/clipboard/clipboard.factor | 2 +-
basis/x11/glx/glx.factor | 2 +-
basis/x11/xim/xim.factor | 2 +-
20 files changed, 37 insertions(+), 32 deletions(-)
diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor
index ebe98a2df1..a0b0e89a0d 100644
--- a/basis/cocoa/messages/messages.factor
+++ b/basis/cocoa/messages/messages.factor
@@ -202,7 +202,7 @@ assoc-union alien>objc-types set-global
[ 0 <uint> [ class_copyMethodList ] keep *uint ] dip
over 0 = [ 3drop ] [
[ <direct-void*-array> ] dip
- [ each ] [ drop underlying>> (free) ] 2bi
+ [ each ] [ drop (free) ] 2bi
] if ; inline
: register-objc-methods ( class -- )
diff --git a/basis/cocoa/views/views.factor b/basis/cocoa/views/views.factor
index 03cafd0a0a..e74e912202 100644
--- a/basis/cocoa/views/views.factor
+++ b/basis/cocoa/views/views.factor
@@ -68,7 +68,7 @@ PRIVATE>
NSOpenGLPFASamples , 8 ,
] when
0 ,
- ] int-array{ } make underlying>>
+ ] int-array{ } make
-> initWithAttributes:
-> autorelease ;
diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor
index b1a9853d55..b9c62f1429 100644
--- a/basis/compiler/tests/alien.factor
+++ b/basis/compiler/tests/alien.factor
@@ -198,8 +198,8 @@ FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ;
FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
[ 32.0 ] [
- { 1.0 2.0 3.0 } >float-array underlying>>
- { 4.0 5.0 6.0 } >float-array underlying>>
+ { 1.0 2.0 3.0 } >float-array
+ { 4.0 5.0 6.0 } >float-array
ffi_test_23
] unit-test
diff --git a/basis/db/postgresql/lib/lib.factor b/basis/db/postgresql/lib/lib.factor
index 19cf5c5002..05114a4deb 100644
--- a/basis/db/postgresql/lib/lib.factor
+++ b/basis/db/postgresql/lib/lib.factor
@@ -65,7 +65,7 @@ M: postgresql-result-null summary ( obj -- str )
} case ;
: param-types ( statement -- seq )
- in-params>> [ type>> type>oid ] uint-array{ } map-as underlying>> ;
+ in-params>> [ type>> type>oid ] uint-array{ } map-as ;
: malloc-byte-array/length ( byte-array -- alien length )
[ malloc-byte-array &free ] [ length ] bi ;
@@ -91,11 +91,11 @@ M: postgresql-result-null summary ( obj -- str )
] 2map flip [
f f
] [
- first2 [ >void*-array underlying>> ] [ >uint-array underlying>> ] bi*
+ first2 [ >void*-array ] [ >uint-array ] bi*
] if-empty ;
: param-formats ( statement -- seq )
- in-params>> [ type>> type>param-format ] uint-array{ } map-as underlying>> ;
+ in-params>> [ type>> type>param-format ] uint-array{ } map-as ;
: do-postgresql-bound-statement ( statement -- res )
[
diff --git a/basis/io/backend/unix/multiplexers/epoll/epoll.factor b/basis/io/backend/unix/multiplexers/epoll/epoll.factor
index a91f62f1df..e1428fee4d 100644
--- a/basis/io/backend/unix/multiplexers/epoll/epoll.factor
+++ b/basis/io/backend/unix/multiplexers/epoll/epoll.factor
@@ -51,7 +51,7 @@ M: epoll-mx remove-output-callbacks ( fd mx -- seq )
] [ 2drop f ] if ;
: wait-event ( mx us -- n )
- [ [ fd>> ] [ events>> ] bi [ underlying>> ] [ length ] bi ] [ 1000 /i ] bi*
+ [ [ fd>> ] [ events>> ] bi dup length ] [ 1000 /i ] bi*
epoll_wait multiplexer-error ;
: handle-event ( event mx -- )
diff --git a/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor b/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor
index 2a6648981b..7bd157136a 100644
--- a/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor
+++ b/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor
@@ -59,7 +59,7 @@ M: kqueue-mx remove-output-callbacks ( fd mx -- seq )
: wait-kevent ( mx timespec -- n )
[
[ fd>> f 0 ]
- [ events>> [ underlying>> ] [ length ] bi ] bi
+ [ events>> dup length ] bi
] dip kevent multiplexer-error ;
: handle-kevent ( mx kevent -- )
diff --git a/basis/io/backend/unix/multiplexers/select/select.factor b/basis/io/backend/unix/multiplexers/select/select.factor
index c62101e478..7d0acb4140 100644
--- a/basis/io/backend/unix/multiplexers/select/select.factor
+++ b/basis/io/backend/unix/multiplexers/select/select.factor
@@ -44,8 +44,8 @@ TUPLE: select-mx < mx read-fdset write-fdset ;
: init-fdsets ( mx -- nfds read write except )
[ num-fds ]
- [ read-fdset/tasks [ init-fdset ] [ underlying>> ] bi ]
- [ write-fdset/tasks [ init-fdset ] [ underlying>> ] bi ] tri
+ [ read-fdset/tasks [ init-fdset ] keep ]
+ [ write-fdset/tasks [ init-fdset ] keep ] tri
f ;
M:: select-mx wait-for-events ( us mx -- )
diff --git a/basis/io/launcher/windows/windows.factor b/basis/io/launcher/windows/windows.factor
index 0497754aa2..7de6c25a13 100755
--- a/basis/io/launcher/windows/windows.factor
+++ b/basis/io/launcher/windows/windows.factor
@@ -103,7 +103,7 @@ TUPLE: CreateProcess-args
over get-environment
[ swap % "=" % % "\0" % ] assoc-each
"\0" %
- ] ushort-array{ } make underlying>>
+ ] ushort-array{ } make
>>lpEnvironment
] when ;
@@ -158,7 +158,7 @@ M: windows kill-process* ( handle -- )
M: windows wait-for-processes ( -- ? )
processes get keys dup
[ handle>> PROCESS_INFORMATION-hProcess ] void*-array{ } map-as
- [ length ] [ underlying>> ] bi 0 0
+ [ length ] keep 0 0
WaitForMultipleObjects
dup HEX: ffffffff = [ win32-error ] when
dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;
diff --git a/basis/io/pipes/unix/unix.factor b/basis/io/pipes/unix/unix.factor
index 6a0015084b..f94733ca56 100644
--- a/basis/io/pipes/unix/unix.factor
+++ b/basis/io/pipes/unix/unix.factor
@@ -7,5 +7,5 @@ QUALIFIED: io.pipes
M: unix io.pipes:(pipe) ( -- pair )
2 <int-array>
- [ underlying>> pipe io-error ]
+ [ pipe io-error ]
[ first2 [ <fd> init-fd ] bi@ io.pipes:pipe boa ] bi ;
diff --git a/basis/libc/libc.factor b/basis/libc/libc.factor
index c4d351e6a0..1e751833a2 100644
--- a/basis/libc/libc.factor
+++ b/basis/libc/libc.factor
@@ -75,14 +75,14 @@ PRIVATE>
dup add-malloc ;
: realloc ( alien size -- newalien )
+ [ >c-ptr ] dip
over malloc-exists? [ realloc-error ] unless
dupd (realloc) check-ptr
swap delete-malloc
dup add-malloc ;
: free ( alien -- )
- dup delete-malloc
- (free) ;
+ >c-ptr [ delete-malloc ] [ (free) ] bi ;
: memcpy ( dst src size -- )
"void" "libc" "memcpy" { "void*" "void*" "ulong" } alien-invoke ;
diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor
index f5868ee7a1..6d9ac95965 100644
--- a/basis/opengl/opengl.factor
+++ b/basis/opengl/opengl.factor
@@ -53,16 +53,16 @@ MACRO: all-enabled-client-state ( seq quot -- )
glMatrixMode glPopMatrix ; inline
: gl-material ( face pname params -- )
- float-array{ } like underlying>> glMaterialfv ;
+ float-array{ } like glMaterialfv ;
: gl-vertex-pointer ( seq -- )
- [ 2 GL_FLOAT 0 ] dip underlying>> glVertexPointer ; inline
+ [ 2 GL_FLOAT 0 ] dip glVertexPointer ; inline
: gl-color-pointer ( seq -- )
- [ 4 GL_FLOAT 0 ] dip underlying>> glColorPointer ; inline
+ [ 4 GL_FLOAT 0 ] dip glColorPointer ; inline
: gl-texture-coord-pointer ( seq -- )
- [ 2 GL_FLOAT 0 ] dip underlying>> glTexCoordPointer ; inline
+ [ 2 GL_FLOAT 0 ] dip glTexCoordPointer ; inline
: line-vertices ( a b -- )
[ first2 [ 0.5 + ] bi@ ] bi@ 4 float-array{ } nsequence
@@ -177,7 +177,7 @@ MACRO: all-enabled-client-state ( seq quot -- )
glActiveTexture swap glBindTexture gl-error ;
: (set-draw-buffers) ( buffers -- )
- [ length ] [ >uint-array underlying>> ] bi glDrawBuffers ;
+ [ length ] [ >uint-array ] bi glDrawBuffers ;
MACRO: set-draw-buffers ( buffers -- )
words>values [ (set-draw-buffers) ] curry ;
diff --git a/basis/opengl/shaders/shaders.factor b/basis/opengl/shaders/shaders.factor
index eb5bbb0ee8..a77d29da2f 100755
--- a/basis/opengl/shaders/shaders.factor
+++ b/basis/opengl/shaders/shaders.factor
@@ -96,7 +96,7 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
dup gl-program-shaders-length
0 <int>
over <uint-array>
- [ underlying>> glGetAttachedShaders ] keep ;
+ [ glGetAttachedShaders ] keep ;
: delete-gl-program-only ( program -- )
glDeleteProgram ; inline
diff --git a/basis/specialized-arrays/specialized-arrays-tests.factor b/basis/specialized-arrays/specialized-arrays-tests.factor
index 1ca041191e..73e719b806 100644
--- a/basis/specialized-arrays/specialized-arrays-tests.factor
+++ b/basis/specialized-arrays/specialized-arrays-tests.factor
@@ -1,7 +1,8 @@
IN: specialized-arrays.tests
USING: tools.test specialized-arrays sequences
specialized-arrays.int specialized-arrays.bool
-specialized-arrays.ushort alien.c-types accessors kernel ;
+specialized-arrays.ushort alien.c-types accessors kernel
+specialized-arrays.direct.int arrays ;
[ t ] [ { 1 2 3 } >int-array int-array? ] unit-test
@@ -16,3 +17,7 @@ specialized-arrays.ushort alien.c-types accessors kernel ;
] unit-test
[ B{ 210 4 1 } byte-array>ushort-array ] must-fail
+
+[ { 3 1 3 3 7 } ] [
+ int-array{ 3 1 3 3 7 } malloc-byte-array 5 <direct-int-array> >array
+] unit-test
\ No newline at end of file
diff --git a/basis/struct-arrays/struct-arrays-tests.factor b/basis/struct-arrays/struct-arrays-tests.factor
index 6f77e66cd2..a8ce98888c 100755
--- a/basis/struct-arrays/struct-arrays-tests.factor
+++ b/basis/struct-arrays/struct-arrays-tests.factor
@@ -22,7 +22,7 @@ C-STRUCT: test-struct
[ 5/4 ] [
[
2 "test-struct" malloc-struct-array
- dup underlying>> &free drop
+ dup &free drop
1 2 make-point over set-first
3 4 make-point over set-second
0 [ [ test-struct-x ] [ test-struct-y ] bi / + ] reduce
@@ -34,6 +34,6 @@ C-STRUCT: test-struct
[ ] [
[
10 "test-struct" malloc-struct-array
- underlying>> &free drop
+ &free drop
] with-destructors
] unit-test
\ No newline at end of file
diff --git a/basis/unix/utilities/utilities.factor b/basis/unix/utilities/utilities.factor
index e2f780cd13..29b137e3de 100644
--- a/basis/unix/utilities/utilities.factor
+++ b/basis/unix/utilities/utilities.factor
@@ -16,5 +16,5 @@ IN: unix.utilities
'[ [ advance ] [ *void* _ alien>string ] bi ]
[ ] produce nip ;
-: strings>alien ( strings encoding -- alien )
- '[ _ malloc-string ] void*-array{ } map-as f suffix underlying>> ;
+: strings>alien ( strings encoding -- array )
+ '[ _ malloc-string ] void*-array{ } map-as f suffix ;
diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor
index 813d8315ac..c86cde23d9 100755
--- a/basis/windows/com/wrapper/wrapper.factor
+++ b/basis/windows/com/wrapper/wrapper.factor
@@ -132,7 +132,7 @@ unless
[ [ 1 ] 2dip set-alien-unsigned-4 ] [ drop ] 2bi ;
: (callbacks>vtbl) ( callbacks -- vtbl )
- [ execute ] void*-array{ } map-as underlying>> malloc-byte-array ;
+ [ execute ] void*-array{ } map-as malloc-byte-array ;
: (callbacks>vtbls) ( callbacks -- vtbls )
[ (callbacks>vtbl) ] map ;
diff --git a/basis/windows/dinput/constants/constants.factor b/basis/windows/dinput/constants/constants.factor
index 0e9a03f075..314fb167e3 100755
--- a/basis/windows/dinput/constants/constants.factor
+++ b/basis/windows/dinput/constants/constants.factor
@@ -59,7 +59,7 @@ SYMBOLS:
struct args <DIOBJECTDATAFORMAT>
i alien set-nth
] each-index
- alien underlying>>
+ alien
] ;
: (DIDATAFORMAT) ( dwSize dwObjSize dwFlags dwDataSize dwNumObjs rgodf alien -- alien )
diff --git a/basis/x11/clipboard/clipboard.factor b/basis/x11/clipboard/clipboard.factor
index d3fe0a8447..8375636a72 100644
--- a/basis/x11/clipboard/clipboard.factor
+++ b/basis/x11/clipboard/clipboard.factor
@@ -51,7 +51,7 @@ TUPLE: x-clipboard atom contents ;
"TARGETS" x-atom 32 PropModeReplace
{
"UTF8_STRING" "STRING" "TARGETS" "TIMESTAMP"
- } [ x-atom ] int-array{ } map-as underlying>>
+ } [ x-atom ] int-array{ } map-as
4 XChangeProperty drop ;
: set-timestamp-prop ( evt -- )
diff --git a/basis/x11/glx/glx.factor b/basis/x11/glx/glx.factor
index e0b786ce7d..11473d6e83 100644
--- a/basis/x11/glx/glx.factor
+++ b/basis/x11/glx/glx.factor
@@ -93,7 +93,7 @@ FUNCTION: void* glXGetProcAddressARB ( char* procname ) ;
GLX_RGBA ,
GLX_DEPTH_SIZE , 16 ,
0 ,
- ] int-array{ } make underlying>>
+ ] int-array{ } make
glXChooseVisual
[ "Could not get a double-buffered GLX RGBA visual" throw ] unless* ;
diff --git a/basis/x11/xim/xim.factor b/basis/x11/xim/xim.factor
index 856420af0f..534e47ac37 100644
--- a/basis/x11/xim/xim.factor
+++ b/basis/x11/xim/xim.factor
@@ -50,7 +50,7 @@ SYMBOL: keysym
: lookup-string ( event xic -- string keysym )
[
prepare-lookup
- swap keybuf get underlying>> buf-size keysym get 0 <int>
+ swap keybuf get buf-size keysym get 0 <int>
XwcLookupString
finish-lookup
] with-scope ;
From 242638fc5c20a70cd96a3dd770ed097fb3327824 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 6 Feb 2009 04:38:31 -0600
Subject: [PATCH 23/36] alien.complex vocabulary implementing support for C99
complex numbers
---
basis/alien/complex/authors.txt | 1 +
basis/alien/complex/complex-tests.factor | 18 ++++++++++
basis/alien/complex/complex.factor | 6 ++++
basis/alien/complex/functor/authors.txt | 1 +
.../complex/functor/functor-tests.factor | 4 +++
basis/alien/complex/functor/functor.factor | 35 +++++++++++++++++++
basis/alien/complex/summary.txt | 1 +
7 files changed, 66 insertions(+)
create mode 100644 basis/alien/complex/authors.txt
create mode 100644 basis/alien/complex/complex-tests.factor
create mode 100644 basis/alien/complex/complex.factor
create mode 100644 basis/alien/complex/functor/authors.txt
create mode 100644 basis/alien/complex/functor/functor-tests.factor
create mode 100644 basis/alien/complex/functor/functor.factor
create mode 100644 basis/alien/complex/summary.txt
diff --git a/basis/alien/complex/authors.txt b/basis/alien/complex/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/alien/complex/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/alien/complex/complex-tests.factor b/basis/alien/complex/complex-tests.factor
new file mode 100644
index 0000000000..bfb2c1137c
--- /dev/null
+++ b/basis/alien/complex/complex-tests.factor
@@ -0,0 +1,18 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test alien.complex kernel alien.c-types alien.syntax
+namespaces ;
+IN: alien.complex.tests
+
+C-STRUCT: complex-holder
+ { "complex-float" "z" } ;
+
+: <complex-holder> ( z -- alien )
+ "complex-holder" <c-object>
+ [ set-complex-holder-z ] keep ;
+
+[ ] [
+ C{ 1.0 2.0 } <complex-holder> "h" set
+] unit-test
+
+[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test
\ No newline at end of file
diff --git a/basis/alien/complex/complex.factor b/basis/alien/complex/complex.factor
new file mode 100644
index 0000000000..60a84b9394
--- /dev/null
+++ b/basis/alien/complex/complex.factor
@@ -0,0 +1,6 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.complex.functor sequences kernel ;
+IN: alien.complex
+
+<< { "float" "double" } [ dup "complex-" prepend define-complex-type ] each >>
\ No newline at end of file
diff --git a/basis/alien/complex/functor/authors.txt b/basis/alien/complex/functor/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/alien/complex/functor/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/alien/complex/functor/functor-tests.factor b/basis/alien/complex/functor/functor-tests.factor
new file mode 100644
index 0000000000..c2df22be1d
--- /dev/null
+++ b/basis/alien/complex/functor/functor-tests.factor
@@ -0,0 +1,4 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test alien.complex.functor ;
+IN: alien.complex.functor.tests
diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor
new file mode 100644
index 0000000000..1d12bb0ff4
--- /dev/null
+++ b/basis/alien/complex/functor/functor.factor
@@ -0,0 +1,35 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.structs alien.c-types math math.functions sequences
+arrays kernel functors vocabs.parser namespaces accessors
+quotations ;
+IN: alien.complex.functor
+
+FUNCTOR: define-complex-type ( N T -- )
+
+T-real DEFINES ${T}-real
+T-imaginary DEFINES ${T}-imaginary
+set-T-real DEFINES set-${T}-real
+set-T-imaginary DEFINES set-${T}-imaginary
+
+>T DEFINES >${T}
+T> DEFINES ${T}>
+
+WHERE
+
+: >T ( z -- alien )
+ >rect T <c-object> [ set-T-imaginary ] [ set-T-real ] [ ] tri ; inline
+
+: T> ( alien -- z )
+ [ T-real ] [ T-imaginary ] bi rect> ; inline
+
+T in get
+{ { N "real" } { N "imaginary" } }
+define-struct
+
+T c-type
+T> 1quotation >>boxer-quot
+>T 1quotation >>unboxer-quot
+drop
+
+;FUNCTOR
\ No newline at end of file
diff --git a/basis/alien/complex/summary.txt b/basis/alien/complex/summary.txt
new file mode 100644
index 0000000000..76c00c1d65
--- /dev/null
+++ b/basis/alien/complex/summary.txt
@@ -0,0 +1 @@
+Implementation details for C99 complex float and complex double types
From 3166828f755bb8e2a0a1c0d4e34e880210cda393 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 6 Feb 2009 04:38:54 -0600
Subject: [PATCH 24/36] Fix bug reported by Doug: smart combinators and inline
words didn't mix very well in some cases
---
basis/combinators/smart/smart-tests.factor | 8 ++++
.../transforms/transforms-tests.factor | 15 ++++++
.../transforms/transforms.factor | 46 ++++++-------------
3 files changed, 38 insertions(+), 31 deletions(-)
diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor
index 370dc26960..69a3a821e5 100644
--- a/basis/combinators/smart/smart-tests.factor
+++ b/basis/combinators/smart/smart-tests.factor
@@ -37,3 +37,11 @@ IN: combinators.smart.tests
[
[ { 1 } { 2 } { 3 } ] B{ } append-outputs-as
] unit-test
+
+! Test nesting
+: nested-smart-combo-test ( -- array )
+ [ [ 1 2 ] output>array [ 3 4 ] output>array ] output>array ;
+
+\ nested-smart-combo-test must-infer
+
+[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test
\ No newline at end of file
diff --git a/basis/stack-checker/transforms/transforms-tests.factor b/basis/stack-checker/transforms/transforms-tests.factor
index 8ae30dcd97..2e2dccd6c4 100644
--- a/basis/stack-checker/transforms/transforms-tests.factor
+++ b/basis/stack-checker/transforms/transforms-tests.factor
@@ -42,3 +42,18 @@ C: <color> color
[ bad-new-test ] must-infer
[ bad-new-test ] must-fail
+
+! Corner case if macro expansion calls 'infer', found by Doug
+DEFER: smart-combo ( quot -- )
+
+\ smart-combo [ infer [ ] curry ] 1 define-transform
+
+[ [ "a" "b" "c" ] smart-combo ] must-infer
+
+[ [ [ "a" "b" ] smart-combo "c" ] smart-combo ] must-infer
+
+: very-smart-combo ( quot -- ) smart-combo ; inline
+
+[ [ "a" "b" "c" ] very-smart-combo ] must-infer
+
+[ [ [ "a" "b" ] very-smart-combo "c" ] very-smart-combo ] must-infer
diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor
index 808ea6a141..e5c2f05d72 100755
--- a/basis/stack-checker/transforms/transforms.factor
+++ b/basis/stack-checker/transforms/transforms.factor
@@ -1,9 +1,9 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors arrays kernel words sequences generic math
namespaces make quotations assocs combinators classes.tuple
classes.tuple.private effects summary hashtables classes generic
-sets definitions generic.standard slots.private continuations
+sets definitions generic.standard slots.private continuations locals
stack-checker.backend stack-checker.state stack-checker.visitor
stack-checker.errors stack-checker.values
stack-checker.recursive-state ;
@@ -15,48 +15,32 @@ IN: stack-checker.transforms
[ dup infer-word apply-word/effect ]
if ;
-: ((apply-transform)) ( word quot values stack -- )
- rot with-datastack first2
- dup [
- [
- [ drop ]
- [ [ length meta-d shorten-by ] [ #drop, ] bi ] bi*
- ] 2dip
- swap infer-quot
- ] [
- 3drop give-up-transform
- ] if ; inline
+:: ((apply-transform)) ( word quot values stack rstate -- )
+ rstate recursive-state
+ [ stack quot with-datastack first ] with-variable
+ [
+ word inlined-dependency depends-on
+ values [ length meta-d shorten-by ] [ #drop, ] bi
+ rstate infer-quot
+ ] [ word give-up-transform ] if* ;
: (apply-transform) ( word quot n -- )
ensure-d dup [ known literal? ] all? [
- dup empty? [
- recursive-state get 1array
- ] [
+ dup empty? [ dup recursive-state get ] [
[ ]
[ [ literal value>> ] map ]
[ first literal recursion>> ] tri
- prefix
] if
((apply-transform))
] [ 2drop give-up-transform ] if ;
: apply-transform ( word -- )
- [ inlined-dependency depends-on ] [
- [ ]
- [ "transform-quot" word-prop ]
- [ "transform-n" word-prop ]
- tri
- (apply-transform)
- ] bi ;
+ [ ] [ "transform-quot" word-prop ] [ "transform-n" word-prop ] tri
+ (apply-transform) ;
: apply-macro ( word -- )
- [ inlined-dependency depends-on ] [
- [ ]
- [ "macro" word-prop ]
- [ "declared-effect" word-prop in>> length ]
- tri
- (apply-transform)
- ] bi ;
+ [ ] [ "macro" word-prop ] [ "declared-effect" word-prop in>> length ] tri
+ (apply-transform) ;
: define-transform ( word quot n -- )
[ drop "transform-quot" set-word-prop ]
From f9bc9a31981a415c5d26cdf01b529fa1fa5ef4c2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 6 Feb 2009 04:53:08 -0600
Subject: [PATCH 25/36] Fix VM compile error
---
vm/math.c | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/vm/math.c b/vm/math.c
index f0aa874886..7bff0de387 100644
--- a/vm/math.c
+++ b/vm/math.c
@@ -530,8 +530,8 @@ void box_double(double flo)
void primitive_from_rect(void)
{
- F_COMPLEX* complex = allot_object(COMPLEX_TYPE,sizeof(F_COMPLEX));
- complex->imaginary = dpop();
- complex->real = dpop();
- dpush(RETAG(complex,COMPLEX_TYPE));
+ F_COMPLEX* z = allot_object(COMPLEX_TYPE,sizeof(F_COMPLEX));
+ z->imaginary = dpop();
+ z->real = dpop();
+ dpush(RETAG(z,COMPLEX_TYPE));
}
From 5579de1722a1490a45a6e069069aafd5420fdac0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 6 Feb 2009 05:09:10 -0600
Subject: [PATCH 26/36] Fix load error in graphics.bitmap tests
---
extra/graphics/bitmap/bitmap-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/graphics/bitmap/bitmap-tests.factor b/extra/graphics/bitmap/bitmap-tests.factor
index 4998427b22..15e960084a 100644
--- a/extra/graphics/bitmap/bitmap-tests.factor
+++ b/extra/graphics/bitmap/bitmap-tests.factor
@@ -1,4 +1,4 @@
-USING: graphics.bitmap ;
+USING: graphics.bitmap graphics.viewer ;
IN: graphics.bitmap.tests
: test-bitmap24 ( -- )
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 27/36] 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 28/36] 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 29/36] 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 30/36] 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 31/36] 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 32/36] 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 33/36] 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 34/36] 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 35/36] 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 36/36] 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 ) ;