From 260862603cceb858ba85d818e75c30d9695158e7 Mon Sep 17 00:00:00 2001
From: Peter Burns <peter@metaweb.com>
Date: Thu, 6 Nov 2008 04:26:49 -0800
Subject: [PATCH 001/157] Added some tests for json.writer, fixed a bug with t
>json and json-null >json
---
basis/json/writer/writer-tests.factor | 18 ++++++++++++++++++
basis/json/writer/writer.factor | 7 +++++--
2 files changed, 23 insertions(+), 2 deletions(-)
create mode 100644 basis/json/writer/writer-tests.factor
diff --git a/basis/json/writer/writer-tests.factor b/basis/json/writer/writer-tests.factor
new file mode 100644
index 0000000000..1b29bac824
--- /dev/null
+++ b/basis/json/writer/writer-tests.factor
@@ -0,0 +1,18 @@
+USING: json.writer tools.test multiline json.reader ;
+IN: json.writer.tests
+
+{ "false" } [ f >json ] unit-test
+{ "true" } [ t >json ] unit-test
+{ "null" } [ json-null >json ] unit-test
+{ "0" } [ 0 >json ] unit-test
+{ "102" } [ 102 >json ] unit-test
+{ "-102" } [ -102 >json ] unit-test
+{ "102.0" } [ 102.0 >json ] unit-test
+{ "102.5" } [ 102.5 >json ] unit-test
+
+{ "[1,\"two\",3.0]" } [ { 1 "two" 3.0 } >json ] unit-test
+{ <" {"US$":1.0,"EU€":1.5}"> } [ H{ { "US$" 1.0 } { "EU€" 1.5 } } >json ] unit-test
+
+! Random symbols are written simply as strings
+SYMBOL: testSymbol
+{ <" "testSymbol""> } [ testSymbol >json ] unit-test
\ No newline at end of file
diff --git a/basis/json/writer/writer.factor b/basis/json/writer/writer.factor
index cbcf426545..4a61aa3438 100644
--- a/basis/json/writer/writer.factor
+++ b/basis/json/writer/writer.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io.streams.string io strings splitting sequences
math math.parser assocs classes words namespaces make
-prettyprint hashtables mirrors tr ;
+prettyprint hashtables mirrors tr json.reader ;
IN: json.writer
#! Writes the object out to a stream in JSON format
@@ -15,6 +15,9 @@ GENERIC: json-print ( obj -- )
M: f json-print ( f -- )
drop "false" write ;
+M: t json-print ( t -- )
+ drop "true" write
+
M: string json-print ( obj -- )
CHAR: " write1 "\"" split "\\\"" join CHAR: \r swap remove "\n" split "\\r\\n" join write CHAR: " write1 ;
@@ -41,4 +44,4 @@ M: hashtable json-print ( hashtable -- )
CHAR: } write1 ;
M: object json-print ( object -- )
- unparse json-print ;
+ dup json-null = [ "null" write drop ] [ unparse json-print ] if ;
From 986ea40835f8e4e1bcb55e873125dc20456e7181 Mon Sep 17 00:00:00 2001
From: Peter Burns <peter@metaweb.com>
Date: Thu, 6 Nov 2008 04:38:12 -0800
Subject: [PATCH 002/157] Changed json-null to a SINGLETON for method dispatch
---
basis/json/reader/reader.factor | 2 +-
basis/json/writer/writer.factor | 7 +++++--
2 files changed, 6 insertions(+), 3 deletions(-)
diff --git a/basis/json/reader/reader.factor b/basis/json/reader/reader.factor
index dd1ab8d5d8..476eefbf95 100644
--- a/basis/json/reader/reader.factor
+++ b/basis/json/reader/reader.factor
@@ -7,7 +7,7 @@ IN: json.reader
! Grammar for JSON from RFC 4627
-SYMBOL: json-null
+SINGLETON: json-null
: [<&>] ( quot -- quot )
{ } make unclip [ <&> ] reduce ;
diff --git a/basis/json/writer/writer.factor b/basis/json/writer/writer.factor
index 4a61aa3438..d572295c3a 100644
--- a/basis/json/writer/writer.factor
+++ b/basis/json/writer/writer.factor
@@ -16,7 +16,10 @@ M: f json-print ( f -- )
drop "false" write ;
M: t json-print ( t -- )
- drop "true" write
+ drop "true" write ;
+
+M: json-null json-print ( null -- )
+ drop "null" write ;
M: string json-print ( obj -- )
CHAR: " write1 "\"" split "\\\"" join CHAR: \r swap remove "\n" split "\\r\\n" join write CHAR: " write1 ;
@@ -44,4 +47,4 @@ M: hashtable json-print ( hashtable -- )
CHAR: } write1 ;
M: object json-print ( object -- )
- dup json-null = [ "null" write drop ] [ unparse json-print ] if ;
+ unparse json-print ;
From e631e1ca0828b61766954418f7d6489491bedf77 Mon Sep 17 00:00:00 2001
From: Peter Burns <peter@metaweb.com>
Date: Thu, 6 Nov 2008 04:41:53 -0800
Subject: [PATCH 003/157] Normalized spacing to 4 space tabs in json modules
---
basis/json/reader/reader.factor | 168 ++++++++++++++++----------------
basis/json/writer/writer.factor | 32 +++---
2 files changed, 100 insertions(+), 100 deletions(-)
diff --git a/basis/json/reader/reader.factor b/basis/json/reader/reader.factor
index 476eefbf95..132cf9ea73 100644
--- a/basis/json/reader/reader.factor
+++ b/basis/json/reader/reader.factor
@@ -10,132 +10,132 @@ IN: json.reader
SINGLETON: json-null
: [<&>] ( quot -- quot )
- { } make unclip [ <&> ] reduce ;
+ { } make unclip [ <&> ] reduce ;
: [<|>] ( quot -- quot )
- { } make unclip [ <|> ] reduce ;
+ { } make unclip [ <|> ] reduce ;
LAZY: 'ws' ( -- parser )
- " " token
- "\n" token <|>
- "\r" token <|>
- "\t" token <|> <*> ;
+ " " token
+ "\n" token <|>
+ "\r" token <|>
+ "\t" token <|> <*> ;
LAZY: spaced ( parser -- parser )
- 'ws' swap &> 'ws' <& ;
+ 'ws' swap &> 'ws' <& ;
LAZY: 'begin-array' ( -- parser )
- "[" token spaced ;
+ "[" token spaced ;
LAZY: 'begin-object' ( -- parser )
- "{" token spaced ;
+ "{" token spaced ;
LAZY: 'end-array' ( -- parser )
- "]" token spaced ;
+ "]" token spaced ;
LAZY: 'end-object' ( -- parser )
- "}" token spaced ;
+ "}" token spaced ;
LAZY: 'name-separator' ( -- parser )
- ":" token spaced ;
+ ":" token spaced ;
LAZY: 'value-separator' ( -- parser )
- "," token spaced ;
+ "," token spaced ;
LAZY: 'false' ( -- parser )
- "false" token [ drop f ] <@ ;
+ "false" token [ drop f ] <@ ;
LAZY: 'null' ( -- parser )
- "null" token [ drop json-null ] <@ ;
+ "null" token [ drop json-null ] <@ ;
LAZY: 'true' ( -- parser )
- "true" token [ drop t ] <@ ;
+ "true" token [ drop t ] <@ ;
LAZY: 'quot' ( -- parser )
- "\"" token ;
+ "\"" token ;
LAZY: 'hex-digit' ( -- parser )
- [ digit> ] satisfy [ digit> ] <@ ;
+ [ digit> ] satisfy [ digit> ] <@ ;
: hex-digits>ch ( digits -- ch )
0 [ swap 16 * + ] reduce ;
LAZY: 'string-char' ( -- parser )
- [ quotable? ] satisfy
- "\\b" token [ drop 8 ] <@ <|>
- "\\t" token [ drop CHAR: \t ] <@ <|>
- "\\n" token [ drop CHAR: \n ] <@ <|>
- "\\f" token [ drop 12 ] <@ <|>
- "\\r" token [ drop CHAR: \r ] <@ <|>
- "\\\"" token [ drop CHAR: " ] <@ <|>
- "\\/" token [ drop CHAR: / ] <@ <|>
- "\\\\" token [ drop CHAR: \\ ] <@ <|>
- "\\u" token 'hex-digit' 4 exactly-n &>
- [ hex-digits>ch ] <@ <|> ;
+ [ quotable? ] satisfy
+ "\\b" token [ drop 8 ] <@ <|>
+ "\\t" token [ drop CHAR: \t ] <@ <|>
+ "\\n" token [ drop CHAR: \n ] <@ <|>
+ "\\f" token [ drop 12 ] <@ <|>
+ "\\r" token [ drop CHAR: \r ] <@ <|>
+ "\\\"" token [ drop CHAR: " ] <@ <|>
+ "\\/" token [ drop CHAR: / ] <@ <|>
+ "\\\\" token [ drop CHAR: \\ ] <@ <|>
+ "\\u" token 'hex-digit' 4 exactly-n &>
+ [ hex-digits>ch ] <@ <|> ;
LAZY: 'string' ( -- parser )
- 'quot'
- 'string-char' <*> &>
- 'quot' <& [ >string ] <@ ;
+ 'quot'
+ 'string-char' <*> &>
+ 'quot' <& [ >string ] <@ ;
DEFER: 'value'
LAZY: 'member' ( -- parser )
- 'string'
- 'name-separator' <&
- 'value' <&> ;
+ 'string'
+ 'name-separator' <&
+ 'value' <&> ;
USE: prettyprint
LAZY: 'object' ( -- parser )
- 'begin-object'
- 'member' 'value-separator' list-of &>
- 'end-object' <& [ >hashtable ] <@ ;
+ 'begin-object'
+ 'member' 'value-separator' list-of &>
+ 'end-object' <& [ >hashtable ] <@ ;
LAZY: 'array' ( -- parser )
- 'begin-array'
- 'value' 'value-separator' list-of &>
- 'end-array' <& ;
+ 'begin-array'
+ 'value' 'value-separator' list-of &>
+ 'end-array' <& ;
LAZY: 'minus' ( -- parser )
- "-" token ;
+ "-" token ;
LAZY: 'plus' ( -- parser )
- "+" token ;
+ "+" token ;
LAZY: 'sign' ( -- parser )
- 'minus' 'plus' <|> ;
+ 'minus' 'plus' <|> ;
LAZY: 'zero' ( -- parser )
- "0" token [ drop 0 ] <@ ;
+ "0" token [ drop 0 ] <@ ;
LAZY: 'decimal-point' ( -- parser )
- "." token ;
+ "." token ;
LAZY: 'digit1-9' ( -- parser )
- [
- dup integer? [
- CHAR: 1 CHAR: 9 between?
- ] [
- drop f
- ] if
- ] satisfy [ digit> ] <@ ;
+ [
+ dup integer? [
+ CHAR: 1 CHAR: 9 between?
+ ] [
+ drop f
+ ] if
+ ] satisfy [ digit> ] <@ ;
LAZY: 'digit0-9' ( -- parser )
- [ digit? ] satisfy [ digit> ] <@ ;
+ [ digit? ] satisfy [ digit> ] <@ ;
: decimal>integer ( seq -- num ) 10 digits>integer ;
LAZY: 'int' ( -- parser )
- 'zero'
- 'digit1-9' 'digit0-9' <*> <&:> [ decimal>integer ] <@ <|> ;
+ 'zero'
+ 'digit1-9' 'digit0-9' <*> <&:> [ decimal>integer ] <@ <|> ;
LAZY: 'e' ( -- parser )
- "e" token "E" token <|> ;
+ "e" token "E" token <|> ;
: sign-number ( pair -- number )
- #! Pair is { minus? num }
- #! Convert the json number value to a factor number
- dup second swap first [ first "-" = [ -1 * ] when ] when* ;
+ #! Pair is { minus? num }
+ #! Convert the json number value to a factor number
+ dup second swap first [ first "-" = [ -1 * ] when ] when* ;
LAZY: 'exp' ( -- parser )
'e'
@@ -143,38 +143,38 @@ LAZY: 'exp' ( -- parser )
'digit0-9' <+> [ decimal>integer ] <@ <&> [ sign-number ] <@ ;
: sequence>frac ( seq -- num )
- #! { 1 2 3 } => 0.123
- reverse 0 [ swap 10 / + ] reduce 10 / >float ;
+ #! { 1 2 3 } => 0.123
+ reverse 0 [ swap 10 / + ] reduce 10 / >float ;
LAZY: 'frac' ( -- parser )
- 'decimal-point' 'digit0-9' <+> &> [ sequence>frac ] <@ ;
+ 'decimal-point' 'digit0-9' <+> &> [ sequence>frac ] <@ ;
: raise-to-power ( pair -- num )
- #! Pair is { num exp }.
- #! Multiply 'num' by 10^exp
- dup second dup [ 10 swap first ^ swap first * ] [ drop first ] if ;
+ #! Pair is { num exp }.
+ #! Multiply 'num' by 10^exp
+ dup second dup [ 10 swap first ^ swap first * ] [ drop first ] if ;
LAZY: 'number' ( -- parser )
- 'sign' <?>
- [ 'int' , 'frac' 0 succeed <|> , ] [<&>] [ sum ] <@
- 'exp' <?> <&> [ raise-to-power ] <@ <&> [ sign-number ] <@ ;
+ 'sign' <?>
+ [ 'int' , 'frac' 0 succeed <|> , ] [<&>] [ sum ] <@
+ 'exp' <?> <&> [ raise-to-power ] <@ <&> [ sign-number ] <@ ;
LAZY: 'value' ( -- parser )
- [
- 'false' ,
- 'null' ,
- 'true' ,
- 'string' ,
- 'object' ,
- 'array' ,
- 'number' ,
- ] [<|>] spaced ;
+ [
+ 'false' ,
+ 'null' ,
+ 'true' ,
+ 'string' ,
+ 'object' ,
+ 'array' ,
+ 'number' ,
+ ] [<|>] spaced ;
ERROR: could-not-parse-json ;
: json> ( string -- object )
- #! Parse a json formatted string to a factor object
- 'value' parse dup nil? [
- could-not-parse-json
- ] [
- car parsed>>
- ] if ;
+ #! Parse a json formatted string to a factor object
+ 'value' parse dup nil? [
+ could-not-parse-json
+ ] [
+ car parsed>>
+ ] if ;
diff --git a/basis/json/writer/writer.factor b/basis/json/writer/writer.factor
index d572295c3a..d50a4de8f5 100644
--- a/basis/json/writer/writer.factor
+++ b/basis/json/writer/writer.factor
@@ -9,42 +9,42 @@ IN: json.writer
GENERIC: json-print ( obj -- )
: >json ( obj -- string )
- #! Returns a string representing the factor object in JSON format
- [ json-print ] with-string-writer ;
+ #! Returns a string representing the factor object in JSON format
+ [ json-print ] with-string-writer ;
M: f json-print ( f -- )
- drop "false" write ;
+ drop "false" write ;
M: t json-print ( t -- )
- drop "true" write ;
+ drop "true" write ;
M: json-null json-print ( null -- )
- drop "null" write ;
+ drop "null" write ;
M: string json-print ( obj -- )
- CHAR: " write1 "\"" split "\\\"" join CHAR: \r swap remove "\n" split "\\r\\n" join write CHAR: " write1 ;
+ CHAR: " write1 "\"" split "\\\"" join CHAR: \r swap remove "\n" split "\\r\\n" join write CHAR: " write1 ;
M: number json-print ( num -- )
- number>string write ;
+ number>string write ;
M: sequence json-print ( array -- )
- CHAR: [ write1 [ >json ] map "," join write CHAR: ] write1 ;
+ CHAR: [ write1 [ >json ] map "," join write CHAR: ] write1 ;
TR: jsvar-encode "-" "_" ;
: tuple>fields ( object -- seq )
- <mirror> [
- [ swap jsvar-encode >json % " : " % >json % ] "" make
- ] { } assoc>map ;
+ <mirror> [
+ [ swap jsvar-encode >json % " : " % >json % ] "" make
+ ] { } assoc>map ;
M: tuple json-print ( tuple -- )
- CHAR: { write1 tuple>fields "," join write CHAR: } write1 ;
+ CHAR: { write1 tuple>fields "," join write CHAR: } write1 ;
M: hashtable json-print ( hashtable -- )
- CHAR: { write1
- [ [ swap jsvar-encode >json % CHAR: : , >json % ] "" make ]
- { } assoc>map "," join write
- CHAR: } write1 ;
+ CHAR: { write1
+ [ [ swap jsvar-encode >json % CHAR: : , >json % ] "" make ]
+ { } assoc>map "," join write
+ CHAR: } write1 ;
M: object json-print ( object -- )
unparse json-print ;
From 6e22f39f469747f309522e63338375a54bd43284 Mon Sep 17 00:00:00 2001
From: Peter Burns <peter@metaweb.com>
Date: Thu, 6 Nov 2008 21:45:24 -0800
Subject: [PATCH 004/157] Rewrote json.reader to use peg.ebnf
---
basis/json/reader/reader.factor | 198 ++++++--------------------------
1 file changed, 37 insertions(+), 161 deletions(-)
diff --git a/basis/json/reader/reader.factor b/basis/json/reader/reader.factor
index 132cf9ea73..0feed3750d 100644
--- a/basis/json/reader/reader.factor
+++ b/basis/json/reader/reader.factor
@@ -1,180 +1,56 @@
-! Copyright (C) 2006 Chris Double.
+! Copyright (C) 2008 Peter Burns.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel parser-combinators namespaces make sequences promises strings
- assocs math math.parser math.vectors math.functions math.order
- lists hashtables ascii accessors ;
+USING: kernel peg peg.ebnf math.parser strings math math.functions sequences
+ arrays vectors hashtables ;
IN: json.reader
! Grammar for JSON from RFC 4627
SINGLETON: json-null
-: [<&>] ( quot -- quot )
- { } make unclip [ <&> ] reduce ;
+EBNF: json>
-: [<|>] ( quot -- quot )
- { } make unclip [ <|> ] reduce ;
+ws = (" " | "\r" | "\t" | "\n")*
-LAZY: 'ws' ( -- parser )
- " " token
- "\n" token <|>
- "\r" token <|>
- "\t" token <|> <*> ;
+hex = [0-9a-fA-F]
-LAZY: spaced ( parser -- parser )
- 'ws' swap &> 'ws' <& ;
+char = '\\"' [[ drop CHAR: " ]]
+ | "\\\\" [[ drop CHAR: \ ]]
+ | "\\/" [[ drop CHAR: / ]]
+ | "\\b" [[ drop 8 ]]
+ | "\\f" [[ drop 12 ]]
+ | "\\n" [[ drop CHAR: \n ]]
+ | "\\r" [[ drop CHAR: \r ]]
+ | "\\t" [[ drop CHAR: \t ]]
+ | "\\u" (hex hex hex hex) [[ hex> ]] => [[ 1 swap nth ]]
+ | [^"\]
-LAZY: 'begin-array' ( -- parser )
- "[" token spaced ;
+string = '"' char*:cs '"' => [[ cs >string ]]
-LAZY: 'begin-object' ( -- parser )
- "{" token spaced ;
+number = base:base exp?:exp => [[ base exp [ exp * ] when ]]
+base = sign?:s float:f => [[ f s "-" = [ neg ] when ]]
+float = digits:int ("." digits)?:frac => [[ int frac [ frac concat append ] when string>number ]]
+digits = [0-9]+ => [[ >string ]]
-LAZY: 'end-array' ( -- parser )
- "]" token spaced ;
+exp = ("e" | "E") (sign)?:s digits:ex => [[ ex string>number s "-" = [ neg ] when 10 swap ^ ]]
+sign = "-" | "+"
-LAZY: 'end-object' ( -- parser )
- "}" token spaced ;
-LAZY: 'name-separator' ( -- parser )
- ":" token spaced ;
+array = "[" elements*:vec "]" => [[ 0 vec nth <reversed> >array ]]
+elements = value:head ("," elements)?:tail => [[ head tail [ 1 tail nth ?push ] [ f ?push ] if ]]
-LAZY: 'value-separator' ( -- parser )
- "," token spaced ;
+object = "{" (members)*:assoc "}" => [[ 0 assoc nth >hashtable ]]
+members = pair:head ("," members)?:tail => [[ head tail [ 1 tail nth ?push ] [ f ?push ] if ]]
+pair = ws string:key ws ":" value:val => [[ { key val } ]]
-LAZY: 'false' ( -- parser )
- "false" token [ drop f ] <@ ;
+val = string
+ | number
+ | object
+ | array
+ | "true" [[ drop t ]]
+ | "false" [[ drop f ]]
+ | "null" [[ drop json-null ]]
-LAZY: 'null' ( -- parser )
- "null" token [ drop json-null ] <@ ;
+value = ws val:v ws => [[ v ]]
-LAZY: 'true' ( -- parser )
- "true" token [ drop t ] <@ ;
-
-LAZY: 'quot' ( -- parser )
- "\"" token ;
-
-LAZY: 'hex-digit' ( -- parser )
- [ digit> ] satisfy [ digit> ] <@ ;
-
-: hex-digits>ch ( digits -- ch )
- 0 [ swap 16 * + ] reduce ;
-
-LAZY: 'string-char' ( -- parser )
- [ quotable? ] satisfy
- "\\b" token [ drop 8 ] <@ <|>
- "\\t" token [ drop CHAR: \t ] <@ <|>
- "\\n" token [ drop CHAR: \n ] <@ <|>
- "\\f" token [ drop 12 ] <@ <|>
- "\\r" token [ drop CHAR: \r ] <@ <|>
- "\\\"" token [ drop CHAR: " ] <@ <|>
- "\\/" token [ drop CHAR: / ] <@ <|>
- "\\\\" token [ drop CHAR: \\ ] <@ <|>
- "\\u" token 'hex-digit' 4 exactly-n &>
- [ hex-digits>ch ] <@ <|> ;
-
-LAZY: 'string' ( -- parser )
- 'quot'
- 'string-char' <*> &>
- 'quot' <& [ >string ] <@ ;
-
-DEFER: 'value'
-
-LAZY: 'member' ( -- parser )
- 'string'
- 'name-separator' <&
- 'value' <&> ;
-
-USE: prettyprint
-LAZY: 'object' ( -- parser )
- 'begin-object'
- 'member' 'value-separator' list-of &>
- 'end-object' <& [ >hashtable ] <@ ;
-
-LAZY: 'array' ( -- parser )
- 'begin-array'
- 'value' 'value-separator' list-of &>
- 'end-array' <& ;
-
-LAZY: 'minus' ( -- parser )
- "-" token ;
-
-LAZY: 'plus' ( -- parser )
- "+" token ;
-
-LAZY: 'sign' ( -- parser )
- 'minus' 'plus' <|> ;
-
-LAZY: 'zero' ( -- parser )
- "0" token [ drop 0 ] <@ ;
-
-LAZY: 'decimal-point' ( -- parser )
- "." token ;
-
-LAZY: 'digit1-9' ( -- parser )
- [
- dup integer? [
- CHAR: 1 CHAR: 9 between?
- ] [
- drop f
- ] if
- ] satisfy [ digit> ] <@ ;
-
-LAZY: 'digit0-9' ( -- parser )
- [ digit? ] satisfy [ digit> ] <@ ;
-
-: decimal>integer ( seq -- num ) 10 digits>integer ;
-
-LAZY: 'int' ( -- parser )
- 'zero'
- 'digit1-9' 'digit0-9' <*> <&:> [ decimal>integer ] <@ <|> ;
-
-LAZY: 'e' ( -- parser )
- "e" token "E" token <|> ;
-
-: sign-number ( pair -- number )
- #! Pair is { minus? num }
- #! Convert the json number value to a factor number
- dup second swap first [ first "-" = [ -1 * ] when ] when* ;
-
-LAZY: 'exp' ( -- parser )
- 'e'
- 'sign' <?> &>
- 'digit0-9' <+> [ decimal>integer ] <@ <&> [ sign-number ] <@ ;
-
-: sequence>frac ( seq -- num )
- #! { 1 2 3 } => 0.123
- reverse 0 [ swap 10 / + ] reduce 10 / >float ;
-
-LAZY: 'frac' ( -- parser )
- 'decimal-point' 'digit0-9' <+> &> [ sequence>frac ] <@ ;
-
-: raise-to-power ( pair -- num )
- #! Pair is { num exp }.
- #! Multiply 'num' by 10^exp
- dup second dup [ 10 swap first ^ swap first * ] [ drop first ] if ;
-
-LAZY: 'number' ( -- parser )
- 'sign' <?>
- [ 'int' , 'frac' 0 succeed <|> , ] [<&>] [ sum ] <@
- 'exp' <?> <&> [ raise-to-power ] <@ <&> [ sign-number ] <@ ;
-
-LAZY: 'value' ( -- parser )
- [
- 'false' ,
- 'null' ,
- 'true' ,
- 'string' ,
- 'object' ,
- 'array' ,
- 'number' ,
- ] [<|>] spaced ;
-ERROR: could-not-parse-json ;
-
-: json> ( string -- object )
- #! Parse a json formatted string to a factor object
- 'value' parse dup nil? [
- could-not-parse-json
- ] [
- car parsed>>
- ] if ;
+;EBNF
\ No newline at end of file
From 706da24b8c58d2617be46c500174799608a5d73b Mon Sep 17 00:00:00 2001
From: Peter Burns <peter@metaweb.com>
Date: Fri, 7 Nov 2008 20:00:19 -0800
Subject: [PATCH 005/157] Refactored json.reader, added a couple more unit
tests, no more rationals
---
basis/json/reader/reader-tests.factor | 6 ++-
basis/json/reader/reader.factor | 60 +++++++++++++--------------
2 files changed, 34 insertions(+), 32 deletions(-)
diff --git a/basis/json/reader/reader-tests.factor b/basis/json/reader/reader-tests.factor
index 995ae0e0b8..84f22f9282 100644
--- a/basis/json/reader/reader-tests.factor
+++ b/basis/json/reader/reader-tests.factor
@@ -8,12 +8,14 @@ IN: json.reader.tests
{ 102 } [ "102" json> ] unit-test
{ -102 } [ "-102" json> ] unit-test
{ 102 } [ "+102" json> ] unit-test
+{ 1000.0 } [ "1.0e3" json> ] unit-test
+{ 1000.0 } [ "10e2" json> ] unit-test
{ 102.0 } [ "102.0" json> ] unit-test
{ 102.5 } [ "102.5" json> ] unit-test
{ 102.5 } [ "102.50" json> ] unit-test
{ -10250.0 } [ "-102.5e2" json> ] unit-test
{ -10250.0 } [ "-102.5E+2" json> ] unit-test
-{ 10+1/4 } [ "1025e-2" json> ] unit-test
+{ 10.25 } [ "1025e-2" json> ] unit-test
{ 0.125 } [ "0.125" json> ] unit-test
{ -0.125 } [ "-0.125" json> ] unit-test
@@ -22,7 +24,9 @@ IN: json.reader.tests
{ 8 9 10 12 13 34 47 92 } >string 1array [ <" "\b\t\n\f\r\"\/\\" "> json> ] unit-test
{ HEX: abcd } >string 1array [ <" "\uaBCd" "> json> ] unit-test
+{ { } } [ "[]" json> ] unit-test
{ { 1 "two" 3.0 } } [ <" [1, "two", 3.0] "> json> ] unit-test
+{ H{ } } [ "{}" json> ] unit-test
{ H{ { "US$" 1.0 } { "EU€" 1.5 } } } [ <" { "US$":1.00, "EU\u20AC":1.50 } "> json> ] unit-test
{ H{
{ "fib" { 1 1 2 3 5 8 H{ { "etc" "etc" } } } }
diff --git a/basis/json/reader/reader.factor b/basis/json/reader/reader.factor
index 0feed3750d..9b50a6bf38 100644
--- a/basis/json/reader/reader.factor
+++ b/basis/json/reader/reader.factor
@@ -1,55 +1,53 @@
! Copyright (C) 2008 Peter Burns.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel peg peg.ebnf math.parser strings math math.functions sequences
- arrays vectors hashtables ;
+USING: kernel peg peg.ebnf math.parser math.private strings math math.functions sequences
+ arrays vectors hashtables prettyprint ;
IN: json.reader
-! Grammar for JSON from RFC 4627
-
SINGLETON: json-null
+! Grammar for JSON from RFC 4627
EBNF: json>
ws = (" " | "\r" | "\t" | "\n")*
-hex = [0-9a-fA-F]
+true = "true" => [[ t ]]
+false = "false" => [[ f ]]
+null = "null" => [[ json-null ]]
-char = '\\"' [[ drop CHAR: " ]]
- | "\\\\" [[ drop CHAR: \ ]]
- | "\\/" [[ drop CHAR: / ]]
- | "\\b" [[ drop 8 ]]
- | "\\f" [[ drop 12 ]]
- | "\\n" [[ drop CHAR: \n ]]
- | "\\r" [[ drop CHAR: \r ]]
- | "\\t" [[ drop CHAR: \t ]]
+hex = [0-9a-fA-F]
+char = '\\"' [[ CHAR: " ]]
+ | "\\\\" [[ CHAR: \ ]]
+ | "\\/" [[ CHAR: / ]]
+ | "\\b" [[ 8 ]]
+ | "\\f" [[ 12 ]]
+ | "\\n" [[ CHAR: \n ]]
+ | "\\r" [[ CHAR: \r ]]
+ | "\\t" [[ CHAR: \t ]]
| "\\u" (hex hex hex hex) [[ hex> ]] => [[ 1 swap nth ]]
| [^"\]
-
string = '"' char*:cs '"' => [[ cs >string ]]
-number = base:base exp?:exp => [[ base exp [ exp * ] when ]]
-base = sign?:s float:f => [[ f s "-" = [ neg ] when ]]
-float = digits:int ("." digits)?:frac => [[ int frac [ frac concat append ] when string>number ]]
-digits = [0-9]+ => [[ >string ]]
+sign = ("-" | "+")? => [[ "-" = [ "-" ] [ "" ] if ]]
+digits = [0-9]+ => [[ >string ]]
+decimal = "." digits => [[ concat ]]
+exp = ("e" | "E") sign digits => [[ concat ]]
+number = sign digits decimal? exp? => [[ dup concat swap fourth [ string>float ] [ string>number ] if ]]
-exp = ("e" | "E") (sign)?:s digits:ex => [[ ex string>number s "-" = [ neg ] when 10 swap ^ ]]
-sign = "-" | "+"
+elements = value ("," value)* => [[ first2 [ second ] map swap prefix >array ]]
+array = "[" elements?:arr "]" => [[ arr { } or ]]
-
-array = "[" elements*:vec "]" => [[ 0 vec nth <reversed> >array ]]
-elements = value:head ("," elements)?:tail => [[ head tail [ 1 tail nth ?push ] [ f ?push ] if ]]
-
-object = "{" (members)*:assoc "}" => [[ 0 assoc nth >hashtable ]]
-members = pair:head ("," members)?:tail => [[ head tail [ 1 tail nth ?push ] [ f ?push ] if ]]
pair = ws string:key ws ":" value:val => [[ { key val } ]]
+members = pair ("," pair)* => [[ first2 [ second ] map swap prefix >hashtable ]]
+object = "{" (members)?:hash "}" => [[ hash H{ } or ]]
-val = string
+val = true
+ | false
+ | null
+ | string
| number
- | object
| array
- | "true" [[ drop t ]]
- | "false" [[ drop f ]]
- | "null" [[ drop json-null ]]
+ | object
value = ws val:v ws => [[ v ]]
From 64cdabf57a386e89520edd20809103be6d10544a Mon Sep 17 00:00:00 2001
From: Peter Burns <peter@metaweb.com>
Date: Sat, 8 Nov 2008 12:08:58 -0800
Subject: [PATCH 006/157] A bit more refactoring and testing of json.reader
---
basis/json/authors.txt | 1 +
basis/json/reader/reader-tests.factor | 12 +++++++++++-
basis/json/reader/reader.factor | 17 ++++++++++-------
3 files changed, 22 insertions(+), 8 deletions(-)
diff --git a/basis/json/authors.txt b/basis/json/authors.txt
index 44b06f94bc..914f818278 100755
--- a/basis/json/authors.txt
+++ b/basis/json/authors.txt
@@ -1 +1,2 @@
Chris Double
+Peter Burns
\ No newline at end of file
diff --git a/basis/json/reader/reader-tests.factor b/basis/json/reader/reader-tests.factor
index 84f22f9282..ed444948a7 100644
--- a/basis/json/reader/reader-tests.factor
+++ b/basis/json/reader/reader-tests.factor
@@ -1,4 +1,4 @@
-USING: arrays json.reader kernel multiline strings tools.test ;
+USING: arrays json.reader kernel multiline strings tools.test hashtables ;
IN: json.reader.tests
{ f } [ "false" json> ] unit-test
@@ -19,14 +19,24 @@ IN: json.reader.tests
{ 0.125 } [ "0.125" json> ] unit-test
{ -0.125 } [ "-0.125" json> ] unit-test
+! not widely supported by javascript, but allowed in the grammar, and a nice
+! feature to get
+{ -0.0 } [ "-0.0" json> ] unit-test
+
{ " fuzzy pickles " } [ <" " fuzzy pickles " "> json> ] unit-test
{ "while 1:\n\tpass" } [ <" "while 1:\n\tpass" "> json> ] unit-test
+! unicode is allowed in json
+{ "ß∂¬ƒ˚∆" } [ <" "ß∂¬ƒ˚∆""> json> ] unit-test
{ 8 9 10 12 13 34 47 92 } >string 1array [ <" "\b\t\n\f\r\"\/\\" "> json> ] unit-test
{ HEX: abcd } >string 1array [ <" "\uaBCd" "> json> ] unit-test
{ { } } [ "[]" json> ] unit-test
{ { 1 "two" 3.0 } } [ <" [1, "two", 3.0] "> json> ] unit-test
{ H{ } } [ "{}" json> ] unit-test
+
+! the returned hashtable should be different every time
+{ H{ } } [ "key" "value" "{}" json> ?set-at "{}" json> swap drop ] unit-test
+
{ H{ { "US$" 1.0 } { "EU€" 1.5 } } } [ <" { "US$":1.00, "EU\u20AC":1.50 } "> json> ] unit-test
{ H{
{ "fib" { 1 1 2 3 5 8 H{ { "etc" "etc" } } } }
diff --git a/basis/json/reader/reader.factor b/basis/json/reader/reader.factor
index 9b50a6bf38..858c9ed4de 100644
--- a/basis/json/reader/reader.factor
+++ b/basis/json/reader/reader.factor
@@ -1,11 +1,14 @@
! Copyright (C) 2008 Peter Burns.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg peg.ebnf math.parser math.private strings math math.functions sequences
- arrays vectors hashtables prettyprint ;
+ arrays vectors hashtables assocs prettyprint ;
IN: json.reader
SINGLETON: json-null
+
+: grammar-list>vector ( seq -- vec ) first2 values swap prefix ;
+
! Grammar for JSON from RFC 4627
EBNF: json>
@@ -24,22 +27,22 @@ char = '\\"' [[ CHAR: " ]]
| "\\n" [[ CHAR: \n ]]
| "\\r" [[ CHAR: \r ]]
| "\\t" [[ CHAR: \t ]]
- | "\\u" (hex hex hex hex) [[ hex> ]] => [[ 1 swap nth ]]
+ | "\\u" (hex hex hex hex) [[ hex> ]] => [[ second ]]
| [^"\]
string = '"' char*:cs '"' => [[ cs >string ]]
-sign = ("-" | "+")? => [[ "-" = [ "-" ] [ "" ] if ]]
+sign = ("-" | "+")? => [[ "-" = "-" "" ? ]]
digits = [0-9]+ => [[ >string ]]
decimal = "." digits => [[ concat ]]
exp = ("e" | "E") sign digits => [[ concat ]]
number = sign digits decimal? exp? => [[ dup concat swap fourth [ string>float ] [ string>number ] if ]]
-elements = value ("," value)* => [[ first2 [ second ] map swap prefix >array ]]
-array = "[" elements?:arr "]" => [[ arr { } or ]]
+elements = value ("," value)* => [[ grammar-list>vector ]]
+array = "[" elements?:arr "]" => [[ arr >array ]]
pair = ws string:key ws ":" value:val => [[ { key val } ]]
-members = pair ("," pair)* => [[ first2 [ second ] map swap prefix >hashtable ]]
-object = "{" (members)?:hash "}" => [[ hash H{ } or ]]
+members = pair ("," pair)* => [[ grammar-list>vector ]]
+object = "{" members?:hash "}" => [[ hash >hashtable ]]
val = true
| false
From a4cecaaf40974238b31dad5804e26cbe48c7ecf6 Mon Sep 17 00:00:00 2001
From: Peter Burns <peter@metaweb.com>
Date: Sat, 8 Nov 2008 13:45:45 -0800
Subject: [PATCH 007/157] swap drop === nip
---
basis/json/reader/reader-tests.factor | 3 +--
1 file changed, 1 insertion(+), 2 deletions(-)
diff --git a/basis/json/reader/reader-tests.factor b/basis/json/reader/reader-tests.factor
index ed444948a7..fbd91601bf 100644
--- a/basis/json/reader/reader-tests.factor
+++ b/basis/json/reader/reader-tests.factor
@@ -35,7 +35,7 @@ IN: json.reader.tests
{ H{ } } [ "{}" json> ] unit-test
! the returned hashtable should be different every time
-{ H{ } } [ "key" "value" "{}" json> ?set-at "{}" json> swap drop ] unit-test
+{ H{ } } [ "key" "value" "{}" json> ?set-at "{}" json> nip ] unit-test
{ H{ { "US$" 1.0 } { "EU€" 1.5 } } } [ <" { "US$":1.00, "EU\u20AC":1.50 } "> json> ] unit-test
{ H{
@@ -54,4 +54,3 @@ IN: json.reader.tests
{ 0 } [ " 0" json> ] unit-test
{ 0 } [ "0 " json> ] unit-test
{ 0 } [ " 0 " json> ] unit-test
-
From 1ca40efa126475c4969859da34f0a935e1c0534e Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Thu, 6 Nov 2008 20:01:31 -0500
Subject: [PATCH 008/157] Adding coreset to extra/coroutines, plus docs and
tests
---
extra/coroutines/coroutines-docs.factor | 8 +++++++-
extra/coroutines/coroutines-tests.factor | 2 ++
extra/coroutines/coroutines.factor | 9 +++++++--
3 files changed, 16 insertions(+), 3 deletions(-)
diff --git a/extra/coroutines/coroutines-docs.factor b/extra/coroutines/coroutines-docs.factor
index 327c60e017..3b2c5033e0 100644
--- a/extra/coroutines/coroutines-docs.factor
+++ b/extra/coroutines/coroutines-docs.factor
@@ -46,7 +46,13 @@ HELP: coyield*
HELP: coterminate
{ $values { "v" "an object" } }
{ $description "Terminate the current coroutine, leaving the value v on the stack when control is passed to the " { $link coresume } " caller. Resuming a terminated coroutine is a no-op." }
-{ $see-also coyield }
+{ $see-also coyield coreset }
+;
+
+HELP: coreset
+{ $values { "v" "an object" } }
+{ $description "Reset the current coroutine, leaving the value v on the stack when control is passed to the " { $link coresume } " caller. When the coroutine is resumed, it will continue at the beginning of the coroutine." }
+{ $see-also coyield coterminate }
;
HELP: current-coro
diff --git a/extra/coroutines/coroutines-tests.factor b/extra/coroutines/coroutines-tests.factor
index 6710452b22..5c443891cb 100644
--- a/extra/coroutines/coroutines-tests.factor
+++ b/extra/coroutines/coroutines-tests.factor
@@ -17,3 +17,5 @@ test1 dup *coresume . dup *coresume . dup *coresume . dup *coresume 2drop
[ [ coyield* ] each ] cocreate ;
{ "c" "b" "a" } [ test3 { "a" "b" "c" } over coresume >r dup *coresume >r *coresume r> r> ] unit-test
+
+{ 4+2/3 } [ [ 1+ coyield 2 * coyield 3 / coreset ] cocreate 1 5 [ over coresume ] times nip ] unit-test
\ No newline at end of file
diff --git a/extra/coroutines/coroutines.factor b/extra/coroutines/coroutines.factor
index dc594abd2d..59b703600c 100644
--- a/extra/coroutines/coroutines.factor
+++ b/extra/coroutines/coroutines.factor
@@ -6,7 +6,7 @@ IN: coroutines
SYMBOL: current-coro
-TUPLE: coroutine resumecc exitcc ;
+TUPLE: coroutine resumecc exitcc originalcc ;
: cocreate ( quot -- co )
coroutine new
@@ -14,7 +14,7 @@ TUPLE: coroutine resumecc exitcc ;
[ swapd , , \ bind ,
"Coroutine has terminated illegally." , \ throw ,
] [ ] make
- >>resumecc ;
+ [ >>resumecc ] [ >>originalcc ] bi ;
: coresume ( v co -- result )
[
@@ -43,3 +43,8 @@ TUPLE: coroutine resumecc exitcc ;
current-coro get
[ ] >>resumecc
exitcc>> continue-with ;
+
+: coreset ( v -- )
+ current-coro get dup
+ originalcc>> >>resumecc
+ exitcc>> continue-with ;
\ No newline at end of file
From e149088f2f04f915cebc5b8b4f02577e6b190f93 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Thu, 6 Nov 2008 20:03:04 -0500
Subject: [PATCH 009/157] Changing extra/advice to use coreset instead of
coterminate
---
extra/advice/advice-tests.factor | 36 ++++++++++++++++++++++++++------
extra/advice/advice.factor | 10 ++++++---
2 files changed, 37 insertions(+), 9 deletions(-)
diff --git a/extra/advice/advice-tests.factor b/extra/advice/advice-tests.factor
index 17b60c8fb1..b359d5596f 100644
--- a/extra/advice/advice-tests.factor
+++ b/extra/advice/advice-tests.factor
@@ -23,18 +23,42 @@ IN: advice.tests
\ bar make-advised
{ 11 } [
- [ 2 * ] "double" \ bar advise-before
- 5 bar
+ [ 2 * ] "double" \ bar advise-before
+ 5 bar
] unit-test
{ 11/3 } [
- [ 3 / ] "third" \ bar advise-after
- 5 bar
+ [ 3 / ] "third" \ bar advise-after
+ 5 bar
] unit-test
{ -2 } [
- [ -1 * ad-do-it 3 + ] "frobnobicate" \ bar advise-around
- 5 bar
+ [ -1 * ad-do-it 3 + ] "frobnobicate" \ bar advise-around
+ 5 bar
] unit-test
+
+: add ( a b -- c ) + ;
+\ add make-advised
+
+ { 10 } [
+ [ [ 2 * ] bi@ ] "double-args" \ add advise-before
+ 2 3 add
+ ] unit-test
+
+ { 21 } [
+ [ 3 * ad-do-it 1- ] "around1" \ add advise-around
+ 2 3 add
+ ] unit-test
+
+ { 9 } [
+ [ [ 1- ] bi@ ad-do-it 2 / ] "around2" \ add advise-around
+ 2 3 add
+ ] unit-test
+
+ { 5 } [
+ \ add unadvise
+ 2 3 add
+ ] unit-test
+
] with-scope
\ No newline at end of file
diff --git a/extra/advice/advice.factor b/extra/advice/advice.factor
index 6a7d46f935..b164c2c1a9 100644
--- a/extra/advice/advice.factor
+++ b/extra/advice/advice.factor
@@ -3,6 +3,8 @@
USING: kernel sequences symbols fry words assocs tools.annotations coroutines ;
IN: advice
+! TODO: What should be the order in which the advice is called?
+
SYMBOLS: before after around advised ;
<PRIVATE
@@ -17,7 +19,7 @@ PRIVATE>
after advise ;
: advise-around ( quot name word -- )
- [ \ coterminate suffix ] 2dip
+ [ \ coreset suffix cocreate ] 2dip
around advise ;
: get-advice ( word type -- seq )
@@ -30,7 +32,7 @@ PRIVATE>
after get-advice [ call ] each ;
: call-around ( main word -- )
- around get-advice [ cocreate ] map tuck
+ around get-advice tuck
[ [ coresume ] each ] [ call ] [ reverse [ coresume ] each ] tri* ;
: remove-advice ( name word loc -- )
@@ -46,4 +48,6 @@ PRIVATE>
[ dup [ over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ]
[ { before after around } [ H{ } clone swap set-word-prop ] with each ]
[ t advised set-word-prop ] tri ;
-
\ No newline at end of file
+
+: unadvise ( word -- )
+ [ reset ] [ { before after around advised } [ f swap set-word-prop ] with each ] bi ;
\ No newline at end of file
From 8cc2f8264cbc74749b587277aa1278c3c3778c5e Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Thu, 6 Nov 2008 20:09:51 -0500
Subject: [PATCH 010/157] Adding name to authors of coroutines
---
extra/coroutines/authors.txt | 1 +
extra/coroutines/coroutines-docs.factor | 2 +-
extra/coroutines/coroutines-tests.factor | 2 +-
extra/coroutines/coroutines.factor | 2 +-
4 files changed, 4 insertions(+), 3 deletions(-)
diff --git a/extra/coroutines/authors.txt b/extra/coroutines/authors.txt
index 7edcfdd138..1a2b8570c4 100644
--- a/extra/coroutines/authors.txt
+++ b/extra/coroutines/authors.txt
@@ -1,2 +1,3 @@
Chris Double
Clemens F. Hofreither
+James Cash
diff --git a/extra/coroutines/coroutines-docs.factor b/extra/coroutines/coroutines-docs.factor
index 3b2c5033e0..6c6bffa64d 100644
--- a/extra/coroutines/coroutines-docs.factor
+++ b/extra/coroutines/coroutines-docs.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither.
+! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither, 2008 James Cash.
USING: help.markup help.syntax ;
IN: coroutines
diff --git a/extra/coroutines/coroutines-tests.factor b/extra/coroutines/coroutines-tests.factor
index 5c443891cb..e07e9725d0 100644
--- a/extra/coroutines/coroutines-tests.factor
+++ b/extra/coroutines/coroutines-tests.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither.
+! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither, 2008 James Cash.
! See http://factorcode.org/license.txt for BSD license.
IN: coroutines.tests
USING: coroutines kernel sequences prettyprint tools.test math ;
diff --git a/extra/coroutines/coroutines.factor b/extra/coroutines/coroutines.factor
index 59b703600c..096e214bd2 100644
--- a/extra/coroutines/coroutines.factor
+++ b/extra/coroutines/coroutines.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither.
+! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither, 2008 James Cash.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel hashtables namespaces make continuations quotations
accessors ;
From b68d3c94a7196035350bbcd7a269276525885327 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Sat, 8 Nov 2008 01:44:53 -0500
Subject: [PATCH 011/157] Adding linked-assocs
---
basis/linked-assocs/authors.txt | 2 +
basis/linked-assocs/linked-assocs-docs.factor | 3 ++
.../linked-assocs/linked-assocs-tests.factor | 26 +++++++++++++
basis/linked-assocs/linked-assocs.factor | 38 +++++++++++++++++++
basis/linked-assocs/summary.txt | 1 +
basis/linked-assocs/tags.txt | 1 +
6 files changed, 71 insertions(+)
create mode 100644 basis/linked-assocs/authors.txt
create mode 100644 basis/linked-assocs/linked-assocs-docs.factor
create mode 100644 basis/linked-assocs/linked-assocs-tests.factor
create mode 100644 basis/linked-assocs/linked-assocs.factor
create mode 100644 basis/linked-assocs/summary.txt
create mode 100644 basis/linked-assocs/tags.txt
diff --git a/basis/linked-assocs/authors.txt b/basis/linked-assocs/authors.txt
new file mode 100644
index 0000000000..35a4db1737
--- /dev/null
+++ b/basis/linked-assocs/authors.txt
@@ -0,0 +1,2 @@
+Slava Pestov
+James Cash
diff --git a/basis/linked-assocs/linked-assocs-docs.factor b/basis/linked-assocs/linked-assocs-docs.factor
new file mode 100644
index 0000000000..74a5fb52ff
--- /dev/null
+++ b/basis/linked-assocs/linked-assocs-docs.factor
@@ -0,0 +1,3 @@
+IN: linked-assocs
+USING: help.markup help.syntax ;
+
diff --git a/basis/linked-assocs/linked-assocs-tests.factor b/basis/linked-assocs/linked-assocs-tests.factor
new file mode 100644
index 0000000000..3ac590041b
--- /dev/null
+++ b/basis/linked-assocs/linked-assocs-tests.factor
@@ -0,0 +1,26 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences assocs tools.test linked-assocs ;
+IN: linked-assocs.test
+
+{ { 1 2 3 } } [
+ <linked-hash> 1 "b" pick set-at
+ 2 "c" pick set-at
+ 3 "a" pick set-at
+ values
+] unit-test
+
+{ 2 t } [
+ <linked-hash> 1 "b" pick set-at
+ 2 "c" pick set-at
+ 3 "a" pick set-at
+ "c" swap at*
+] unit-test
+
+{ { 2 3 4 } { "c" "a" "d" } } [
+ <linked-hash> 1 "a" pick set-at
+ 2 "c" pick set-at
+ 3 "a" pick set-at
+ 4 "d" pick set-at
+ [ values ] [ keys ] bi
+] unit-test
\ No newline at end of file
diff --git a/basis/linked-assocs/linked-assocs.factor b/basis/linked-assocs/linked-assocs.factor
new file mode 100644
index 0000000000..f9849324df
--- /dev/null
+++ b/basis/linked-assocs/linked-assocs.factor
@@ -0,0 +1,38 @@
+! Copyright (C) 2008 Slava Pestov, James Cash.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs arrays kernel deques dlists sequences hashtables fry ;
+IN: linked-assocs
+
+TUPLE: linked-assoc assoc dlist ;
+
+: <linked-hash> ( -- assoc )
+ 0 <hashtable> <dlist> linked-assoc boa ;
+
+M: linked-assoc assoc-size assoc>> assoc-size ;
+
+M: linked-assoc at* assoc>> at* tuck [ obj>> ] when swap ;
+
+<PRIVATE
+: add-to-dlist ( value key lassoc -- node )
+ [ swap 2array ] dip dlist>> push-back* ;
+
+: remove-from-dlist ( key dlist -- )
+ swap '[ _ = ] delete-node-if ;
+PRIVATE>
+
+M: linked-assoc set-at
+ [ add-to-dlist ] 2keep
+ assoc>> set-at ;
+
+M: linked-assoc delete-at
+ [ [ assoc>> ] [ dlist>> ] bi [ at ] dip '[ _ delete-node ] when* ]
+ [ assoc>> delete-at ]
+ 2bi ;
+
+: dlist>seq ( dlist -- seq )
+ [ ] pusher [ dlist-each ] dip ;
+
+M: linked-assoc >alist
+ dlist>> dlist>seq ;
+
+INSTANCE: linked-assoc assoc
diff --git a/basis/linked-assocs/summary.txt b/basis/linked-assocs/summary.txt
new file mode 100644
index 0000000000..54b0d14d4c
--- /dev/null
+++ b/basis/linked-assocs/summary.txt
@@ -0,0 +1 @@
+Assocs that yield items in insertion order
diff --git a/basis/linked-assocs/tags.txt b/basis/linked-assocs/tags.txt
new file mode 100644
index 0000000000..031765c41b
--- /dev/null
+++ b/basis/linked-assocs/tags.txt
@@ -0,0 +1 @@
+assocs
From b3acebc350b646cfc1f4a93ce0e72cbf1b59466f Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Sat, 8 Nov 2008 02:18:03 -0500
Subject: [PATCH 012/157] linked-assocs passes tests
---
basis/linked-assocs/linked-assocs.factor | 23 ++++++++++-------------
1 file changed, 10 insertions(+), 13 deletions(-)
diff --git a/basis/linked-assocs/linked-assocs.factor b/basis/linked-assocs/linked-assocs.factor
index f9849324df..ee29869dfd 100644
--- a/basis/linked-assocs/linked-assocs.factor
+++ b/basis/linked-assocs/linked-assocs.factor
@@ -10,25 +10,22 @@ TUPLE: linked-assoc assoc dlist ;
M: linked-assoc assoc-size assoc>> assoc-size ;
-M: linked-assoc at* assoc>> at* tuck [ obj>> ] when swap ;
-
-<PRIVATE
-: add-to-dlist ( value key lassoc -- node )
- [ swap 2array ] dip dlist>> push-back* ;
-
-: remove-from-dlist ( key dlist -- )
- swap '[ _ = ] delete-node-if ;
-PRIVATE>
-
-M: linked-assoc set-at
- [ add-to-dlist ] 2keep
- assoc>> set-at ;
+M: linked-assoc at* assoc>> at* tuck [ obj>> ] when second swap ;
M: linked-assoc delete-at
[ [ assoc>> ] [ dlist>> ] bi [ at ] dip '[ _ delete-node ] when* ]
[ assoc>> delete-at ]
2bi ;
+<PRIVATE
+: add-to-dlist ( value key lassoc -- node )
+ [ swap 2array ] dip dlist>> push-back* ;
+PRIVATE>
+
+M: linked-assoc set-at
+ [ 2dup assoc>> key? [ 2dup delete-at ] when add-to-dlist ] 2keep
+ assoc>> set-at ;
+
: dlist>seq ( dlist -- seq )
[ ] pusher [ dlist-each ] dip ;
From 41b7853e082e121a276ac91c57394db8bc81e5c9 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Sat, 8 Nov 2008 12:21:32 -0500
Subject: [PATCH 013/157] Adding more assoc protocol methods to linked-assocs,
bugfixes
---
basis/linked-assocs/linked-assocs.factor | 12 +++++++++---
1 file changed, 9 insertions(+), 3 deletions(-)
diff --git a/basis/linked-assocs/linked-assocs.factor b/basis/linked-assocs/linked-assocs.factor
index ee29869dfd..215b414e4b 100644
--- a/basis/linked-assocs/linked-assocs.factor
+++ b/basis/linked-assocs/linked-assocs.factor
@@ -10,12 +10,11 @@ TUPLE: linked-assoc assoc dlist ;
M: linked-assoc assoc-size assoc>> assoc-size ;
-M: linked-assoc at* assoc>> at* tuck [ obj>> ] when second swap ;
+M: linked-assoc at* assoc>> at* tuck [ obj>> second ] when swap ;
M: linked-assoc delete-at
[ [ assoc>> ] [ dlist>> ] bi [ at ] dip '[ _ delete-node ] when* ]
- [ assoc>> delete-at ]
- 2bi ;
+ [ assoc>> delete-at ] 2bi ;
<PRIVATE
: add-to-dlist ( value key lassoc -- node )
@@ -32,4 +31,11 @@ M: linked-assoc set-at
M: linked-assoc >alist
dlist>> dlist>seq ;
+M: linked-assoc clear-assoc
+ [ assoc>> clear-assoc ] [ dlist>> clear-deque ] bi ;
+
+M: linked-assoc clone
+ [ assoc>> clone ] [ dlist>> clone ] bi
+ linked-assoc boa ;
+
INSTANCE: linked-assoc assoc
From 143567c9178f55cd5ac0d7d16248df383dbcc360 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Sat, 8 Nov 2008 12:21:50 -0500
Subject: [PATCH 014/157] More tests for linked-assocs
---
.../linked-assocs/linked-assocs-tests.factor | 29 +++++++++++++++++--
1 file changed, 26 insertions(+), 3 deletions(-)
diff --git a/basis/linked-assocs/linked-assocs-tests.factor b/basis/linked-assocs/linked-assocs-tests.factor
index 3ac590041b..64d5c60481 100644
--- a/basis/linked-assocs/linked-assocs-tests.factor
+++ b/basis/linked-assocs/linked-assocs-tests.factor
@@ -17,10 +17,33 @@ IN: linked-assocs.test
"c" swap at*
] unit-test
-{ { 2 3 4 } { "c" "a" "d" } } [
+{ { 2 3 4 } { "c" "a" "d" } 3 } [
<linked-hash> 1 "a" pick set-at
2 "c" pick set-at
3 "a" pick set-at
4 "d" pick set-at
- [ values ] [ keys ] bi
-] unit-test
\ No newline at end of file
+ [ values ] [ keys ] [ assoc-size ] tri
+] unit-test
+
+{ f 1 } [
+ <linked-hash> 1 "c" pick set-at
+ 2 "b" pick set-at
+ "c" over delete-at
+ "c" over at swap assoc-size
+] unit-test
+
+{ { } 0 } [
+ <linked-hash> 1 "a" pick set-at
+ 2 "c" pick set-at
+ 3 "a" pick set-at
+ 4 "d" pick set-at
+ dup clear-assoc [ keys ] [ assoc-size ] bi
+] unit-test
+
+{ { } { 1 2 3 } } [
+ <linked-hash> dup clone
+ 1 "c" pick set-at
+ 2 "q" pick set-at
+ 3 "a" pick set-at
+ [ values ] bi@
+] unit-test
From d9076407fb75c31d697572292a237e8307198d7b Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Sat, 8 Nov 2008 12:22:06 -0500
Subject: [PATCH 015/157] Writing docs for linked-assocs
---
basis/linked-assocs/linked-assocs-docs.factor | 22 ++++++++++++++++++-
1 file changed, 21 insertions(+), 1 deletion(-)
diff --git a/basis/linked-assocs/linked-assocs-docs.factor b/basis/linked-assocs/linked-assocs-docs.factor
index 74a5fb52ff..8f73bdfd36 100644
--- a/basis/linked-assocs/linked-assocs-docs.factor
+++ b/basis/linked-assocs/linked-assocs-docs.factor
@@ -1,3 +1,23 @@
IN: linked-assocs
-USING: help.markup help.syntax ;
+USING: help.markup help.syntax assocs ;
+HELP: linked-assoc
+{ $class-description "The class of linked assocs. Linked assoc are implemented by combining an assocs and a dlist. The assoc is used for lookup and retrieval of single values, while the dlist is used for getting lists of keys/values, which will be in insertion order." } ;
+
+HELP: <linked-hash>
+{ $values { "assoc" "A new linked-assoc" } }
+{ $description "Creates a new, empty linked assoc." } ;
+
+ARTICLE: "linked-assocs" "Linked assocs"
+"A " { $emphasis "linked assoc" } " is an assoc which combines a hash table and a dlist to form a structure which has the insertion and retrieval characteristics of a hash table, but with the ability to get the items in insertion order."
+$nl
+"Linked assocs implement the following methods from the assoc protocol:"
+{ $subsection at* }
+{ $subsection assoc-size }
+{ $subsection >alist }
+{ $subsection set-at }
+{ $subsection delete-at }
+{ $subsection clear-assoc }
+{ $subsection >alist } ;
+
+ABOUT: "linked-assocs"
\ No newline at end of file
From cc877bf79b786c3a822ec91aeafc669586505e14 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Sat, 8 Nov 2008 13:33:42 -0500
Subject: [PATCH 016/157] Fixing identation in advice-tests
---
extra/advice/advice-tests.factor | 119 +++++++++++++++++++------------
1 file changed, 74 insertions(+), 45 deletions(-)
diff --git a/extra/advice/advice-tests.factor b/extra/advice/advice-tests.factor
index b359d5596f..ece4cb52a7 100644
--- a/extra/advice/advice-tests.factor
+++ b/extra/advice/advice-tests.factor
@@ -1,64 +1,93 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences math tools.test advice parser namespaces ;
+USING: kernel sequences io io.streams.string math tools.test advice math.parser
+parser namespaces multiline eval words assocs ;
IN: advice.tests
[
-: foo "foo" ;
-\ foo make-advised
+ [ ad-do-it ] must-fail
+
+ : foo "foo" ;
+ \ foo make-advised
- { "bar" "foo" } [
- [ "bar" ] "barify" \ foo advise-before
- foo ] unit-test
+ { "bar" "foo" } [
+ [ "bar" ] "barify" \ foo advise-before
+ foo
+ ] unit-test
- { "bar" "foo" "baz" } [
- [ "baz" ] "bazify" \ foo advise-after
- foo ] unit-test
+ { "bar" "foo" "baz" } [
+ [ "baz" ] "bazify" \ foo advise-after
+ foo
+ ] unit-test
- { "foo" "baz" } [
- "barify" \ foo before remove-advice
- foo ] unit-test
+ { "foo" "baz" } [
+ "barify" \ foo before remove-advice
+ foo
+ ] unit-test
-: bar ( a -- b ) 1+ ;
-\ bar make-advised
+ : bar ( a -- b ) 1+ ;
+ \ bar make-advised
- { 11 } [
- [ 2 * ] "double" \ bar advise-before
- 5 bar
- ] unit-test
+ { 11 } [
+ [ 2 * ] "double" \ bar advise-before
+ 5 bar
+ ] unit-test
- { 11/3 } [
- [ 3 / ] "third" \ bar advise-after
- 5 bar
- ] unit-test
+ { 11/3 } [
+ [ 3 / ] "third" \ bar advise-after
+ 5 bar
+ ] unit-test
- { -2 } [
- [ -1 * ad-do-it 3 + ] "frobnobicate" \ bar advise-around
- 5 bar
- ] unit-test
+ { -2 } [
+ [ -1 * ad-do-it 3 + ] "frobnobicate" \ bar advise-around
+ 5 bar
+ ] unit-test
-: add ( a b -- c ) + ;
-\ add make-advised
+ : add ( a b -- c ) + ;
+ \ add make-advised
- { 10 } [
- [ [ 2 * ] bi@ ] "double-args" \ add advise-before
- 2 3 add
- ] unit-test
+ { 10 } [
+ [ [ 2 * ] bi@ ] "double-args" \ add advise-before
+ 2 3 add
+ ] unit-test
- { 21 } [
- [ 3 * ad-do-it 1- ] "around1" \ add advise-around
- 2 3 add
- ] unit-test
+ { 21 } [
+ [ 3 * ad-do-it 1- ] "around1" \ add advise-around
+ 2 3 add
+ ] unit-test
- { 9 } [
- [ [ 1- ] bi@ ad-do-it 2 / ] "around2" \ add advise-around
- 2 3 add
- ] unit-test
+ { 9 } [
+ [ [ 1- ] bi@ ad-do-it 2 / ] "around2" \ add advise-around
+ 2 3 add
+ ] unit-test
- { 5 } [
- \ add unadvise
- 2 3 add
- ] unit-test
+ { { "around1" "around2" } } [
+ \ add around word-prop keys
+ ] unit-test
+ { 5 f } [
+ \ add unadvise
+ 2 3 add \ add advised?
+ ] unit-test
+
+ : quux ( a b -- c ) * ;
+
+ { f t 3+3/4 } [
+ <" USING: advice kernel math ;
+ IN: advice.tests
+ \ quux advised?
+ ADVISE: quux halve before [ 2 / ] bi@ ;
+ \ quux advised?
+ 3 5 quux"> eval
+ ] unit-test
+
+ { 3+3/4 "1+1/2 2+1/2 3+3/4" } [
+ <" USING: advice kernel math math.parser io io.streams.string ; IN: advice.tests
+ ADVISE: quux log around
+ 2dup [ number>string write " " write ] bi@
+ ad-do-it
+ dup number>string write ;
+ [ 3 5 quux ] with-string-writer"> eval
+ ] unit-test
- ] with-scope
\ No newline at end of file
+] with-scope
\ No newline at end of file
From ec7bc276dc429a87c2fa0b0719c6e8c5c8f3db3a Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Sat, 8 Nov 2008 13:38:56 -0500
Subject: [PATCH 017/157] Adding documentation for ad-do-it
---
extra/advice/advice-docs.factor | 7 ++++++-
1 file changed, 6 insertions(+), 1 deletion(-)
diff --git a/extra/advice/advice-docs.factor b/extra/advice/advice-docs.factor
index 7b523e9a8c..2c470d04b3 100644
--- a/extra/advice/advice-docs.factor
+++ b/extra/advice/advice-docs.factor
@@ -1,5 +1,5 @@
IN: advice
-USING: help.markup help.syntax tools.annotations words ;
+USING: help.markup help.syntax tools.annotations words coroutines ;
HELP: make-advised
{ $values { "word" "a word to annotate in preparation of advising" } }
@@ -16,6 +16,11 @@ HELP: advised?
{ $values { "word" "a word" } { "?" "t or f, indicating if " { $snippet "word" } " is advised" } }
{ $description "Determines whether or not the given word has any advice on it." } ;
+HELP: ad-do-it
+{ $values { "input" "an object" } { "output" "an object" } }
+{ $description "Calls either the next applicable around advice or the main body, returning back to the point it was called from when finished. This word should only be called from inside advice." }
+{ $see-also coyield } ;
+
ARTICLE: "advice" "Advice"
"Advice is a simple way of adding additition functionality to words by adding 'hooks' to a word, which can act before, after, or around the calling of the word." ;
From 44bfc0f802e18eaf3c0dce1dc22b5e603821a97f Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Tue, 11 Nov 2008 01:31:22 -0500
Subject: [PATCH 018/157] More work on advice, cleaning it up (TESTS FAIL)
---
extra/advice/advice.factor | 54 ++++++++++++++++++++++----------------
1 file changed, 32 insertions(+), 22 deletions(-)
diff --git a/extra/advice/advice.factor b/extra/advice/advice.factor
index b164c2c1a9..383812e602 100644
--- a/extra/advice/advice.factor
+++ b/extra/advice/advice.factor
@@ -1,26 +1,31 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences symbols fry words assocs tools.annotations coroutines ;
+USING: kernel sequences symbols fry words assocs linked-assocs tools.annotations
+coroutines lexer parser quotations arrays namespaces continuations ;
IN: advice
-! TODO: What should be the order in which the advice is called?
+SYMBOLS: before after around advised in-advice? ;
-SYMBOLS: before after around advised ;
+: advised? ( word -- ? )
+ advised word-prop ;
+
+DEFER: make-advised
<PRIVATE
-: advise ( quot name word loc -- )
- word-prop set-at ;
+: init-around-co ( quot -- coroutine )
+ \ coreset suffix cocreate ;
PRIVATE>
-
-: advise-before ( quot name word -- )
- before advise ;
-
-: advise-after ( quot name word -- )
- after advise ;
-: advise-around ( quot name word -- )
- [ \ coreset suffix cocreate ] 2dip
- around advise ;
+: advise ( quot name word loc -- )
+ dup around eq? [ [ init-around-co ] 3dip ] when
+ over advised? [ over make-advised ] unless
+ word-prop set-at ;
+
+: advise-before ( quot name word -- ) before advise ;
+
+: advise-after ( quot name word -- ) after advise ;
+
+: advise-around ( quot name word -- ) around advise ;
: get-advice ( word type -- seq )
word-prop values ;
@@ -32,22 +37,27 @@ PRIVATE>
after get-advice [ call ] each ;
: call-around ( main word -- )
- around get-advice tuck
- [ [ coresume ] each ] [ call ] [ reverse [ coresume ] each ] tri* ;
+ t in-advice? [
+ around get-advice tuck
+ [ [ coresume ] each ] [ call ] [ <reversed> [ coresume ] each ] tri*
+ ] with-variable ;
: remove-advice ( name word loc -- )
word-prop delete-at ;
: ad-do-it ( input -- result )
- coyield ;
-
-: advised? ( word -- ? )
- advised word-prop ;
+ in-advice? get [ "ad-do-it should only be called inside 'around' advice" throw ] unless coyield ;
: make-advised ( word -- )
[ dup [ over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ]
- [ { before after around } [ H{ } clone swap set-word-prop ] with each ]
+ [ { before after around } [ <linked-hash> swap set-word-prop ] with each ]
[ t advised set-word-prop ] tri ;
: unadvise ( word -- )
- [ reset ] [ { before after around advised } [ f swap set-word-prop ] with each ] bi ;
\ No newline at end of file
+ [ reset ] [ { before after around advised } [ f swap set-word-prop ] with each ] bi ;
+
+: ADVISE: ! word adname location => word adname quot loc
+ scan-word scan scan-word parse-definition swap [ spin ] dip advise ; parsing
+
+: UNADVISE:
+ scan-word parsed \ unadvise parsed ; parsing
\ No newline at end of file
From a5576bbb1d99eb0e9f0cf14e9e48e8af2c913bd5 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Tue, 11 Nov 2008 02:04:25 -0500
Subject: [PATCH 019/157] Fixing extra space, replacing tuck ... swap with [
... ] keep
---
basis/linked-assocs/linked-assocs.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/linked-assocs/linked-assocs.factor b/basis/linked-assocs/linked-assocs.factor
index 215b414e4b..54f4be7269 100644
--- a/basis/linked-assocs/linked-assocs.factor
+++ b/basis/linked-assocs/linked-assocs.factor
@@ -10,7 +10,7 @@ TUPLE: linked-assoc assoc dlist ;
M: linked-assoc assoc-size assoc>> assoc-size ;
-M: linked-assoc at* assoc>> at* tuck [ obj>> second ] when swap ;
+M: linked-assoc at* assoc>> at* [ [ obj>> second ] when ] keep ;
M: linked-assoc delete-at
[ [ assoc>> ] [ dlist>> ] bi [ at ] dip '[ _ delete-node ] when* ]
@@ -22,7 +22,7 @@ M: linked-assoc delete-at
PRIVATE>
M: linked-assoc set-at
- [ 2dup assoc>> key? [ 2dup delete-at ] when add-to-dlist ] 2keep
+ [ 2dup assoc>> key? [ 2dup delete-at ] when add-to-dlist ] 2keep
assoc>> set-at ;
: dlist>seq ( dlist -- seq )
From da3399f31d4a3ebd9302e032176c9f3aa8e45f06 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Tue, 11 Nov 2008 02:04:40 -0500
Subject: [PATCH 020/157] More tests for linked-assocs
---
basis/linked-assocs/linked-assocs-tests.factor | 10 +++++++++-
1 file changed, 9 insertions(+), 1 deletion(-)
diff --git a/basis/linked-assocs/linked-assocs-tests.factor b/basis/linked-assocs/linked-assocs-tests.factor
index 64d5c60481..7a259ee59a 100644
--- a/basis/linked-assocs/linked-assocs-tests.factor
+++ b/basis/linked-assocs/linked-assocs-tests.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences assocs tools.test linked-assocs ;
+USING: kernel sequences assocs tools.test linked-assocs math ;
IN: linked-assocs.test
{ { 1 2 3 } } [
@@ -47,3 +47,11 @@ IN: linked-assocs.test
3 "a" pick set-at
[ values ] bi@
] unit-test
+
+{ 9 } [
+ <linked-hash>
+ { [ 3 * ] [ 1- ] } "first" pick set-at
+ { [ [ 1- ] bi@ ] [ 2 / ] } "second" pick set-at
+ 4 6 pick values [ first call ] each
+ + swap values <reversed> [ second call ] each
+] unit-test
\ No newline at end of file
From b693cd8ab1293d5478bfedc0713af7a1cf4f7a0f Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Tue, 11 Nov 2008 02:31:37 -0500
Subject: [PATCH 021/157] Adding coreset to description in comments
---
extra/coroutines/coroutines.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/coroutines/coroutines.factor b/extra/coroutines/coroutines.factor
index 096e214bd2..51276336e3 100644
--- a/extra/coroutines/coroutines.factor
+++ b/extra/coroutines/coroutines.factor
@@ -21,7 +21,7 @@ TUPLE: coroutine resumecc exitcc originalcc ;
>>exitcc
resumecc>> call
#! At this point, the coroutine quotation must have terminated
- #! normally (without calling coyield or coterminate). This shouldn't happen.
+ #! normally (without calling coyield, coreset, or coterminate). This shouldn't happen.
f over
] callcc1 2nip ;
From 62e6a139c3ceda9a09f8ef7cfbf7c79751ec710b Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Tue, 11 Nov 2008 02:31:53 -0500
Subject: [PATCH 022/157] Commenting out failing tests for push
---
extra/advice/advice-tests.factor | 49 ++++++++++++++++----------------
1 file changed, 25 insertions(+), 24 deletions(-)
diff --git a/extra/advice/advice-tests.factor b/extra/advice/advice-tests.factor
index ece4cb52a7..be16150c2e 100644
--- a/extra/advice/advice-tests.factor
+++ b/extra/advice/advice-tests.factor
@@ -56,38 +56,39 @@ IN: advice.tests
2 3 add
] unit-test
- { 9 } [
- [ [ 1- ] bi@ ad-do-it 2 / ] "around2" \ add advise-around
- 2 3 add
- ] unit-test
+! { 9 } [
+! [ [ 1- ] bi@ ad-do-it 2 / ] "around2" \ add advise-around
+! 2 3 add
+! ] unit-test
- { { "around1" "around2" } } [
- \ add around word-prop keys
- ] unit-test
+! { { "around1" "around2" } } [
+! \ add around word-prop keys
+! ] unit-test
{ 5 f } [
\ add unadvise
2 3 add \ add advised?
] unit-test
- : quux ( a b -- c ) * ;
+! : quux ( a b -- c ) * ;
- { f t 3+3/4 } [
- <" USING: advice kernel math ;
- IN: advice.tests
- \ quux advised?
- ADVISE: quux halve before [ 2 / ] bi@ ;
- \ quux advised?
- 3 5 quux"> eval
- ] unit-test
+! { f t 3+3/4 } [
+! <" USING: advice kernel math ;
+! IN: advice.tests
+! \ quux advised?
+! ADVISE: quux halve before [ 2 / ] bi@ ;
+! \ quux advised?
+! 3 5 quux"> eval
+! ] unit-test
- { 3+3/4 "1+1/2 2+1/2 3+3/4" } [
- <" USING: advice kernel math math.parser io io.streams.string ; IN: advice.tests
- ADVISE: quux log around
- 2dup [ number>string write " " write ] bi@
- ad-do-it
- dup number>string write ;
- [ 3 5 quux ] with-string-writer"> eval
- ] unit-test
+! { 3+3/4 "1+1/2 2+1/2 3+3/4" } [
+! <" USING: advice kernel math math.parser io io.streams.string ;
+! IN: advice.tests
+! ADVISE: quux log around
+! 2dup [ number>string write " " write ] bi@
+! ad-do-it
+! dup number>string write ;
+! [ 3 5 quux ] with-string-writer"> eval
+! ] unit-test
] with-scope
\ No newline at end of file
From 5c6860fd0f034a9bb47ff28d47b2cb8dacb1334d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 11 Nov 2008 17:42:52 -0600
Subject: [PATCH 023/157] Updating linked-assocs documentation, add
<linked-assoc> word
---
basis/linked-assocs/linked-assocs-docs.factor | 24 +++++++++----------
basis/linked-assocs/linked-assocs.factor | 7 ++++--
2 files changed, 17 insertions(+), 14 deletions(-)
diff --git a/basis/linked-assocs/linked-assocs-docs.factor b/basis/linked-assocs/linked-assocs-docs.factor
index 8f73bdfd36..31f387aeb9 100644
--- a/basis/linked-assocs/linked-assocs-docs.factor
+++ b/basis/linked-assocs/linked-assocs-docs.factor
@@ -2,22 +2,22 @@ IN: linked-assocs
USING: help.markup help.syntax assocs ;
HELP: linked-assoc
-{ $class-description "The class of linked assocs. Linked assoc are implemented by combining an assocs and a dlist. The assoc is used for lookup and retrieval of single values, while the dlist is used for getting lists of keys/values, which will be in insertion order." } ;
+{ $class-description "The class of linked assocs. Linked assoc are implemented by combining an assoc with a dlist. The assoc is used for lookup and retrieval of single values, while the dlist is used for getting lists of keys/values, which will be in insertion order." } ;
+
+HELP: <linked-assoc>
+{ $values { "exemplar" "an exemplar assoc" } }
+{ $description "Creates an empty linked assoc backed by a new instance of the same type as the exemplar." } ;
HELP: <linked-hash>
-{ $values { "assoc" "A new linked-assoc" } }
-{ $description "Creates a new, empty linked assoc." } ;
+{ $values { "assoc" linked-assoc } }
+{ $description "Creates an empty linked assoc backed by a hashtable." } ;
ARTICLE: "linked-assocs" "Linked assocs"
-"A " { $emphasis "linked assoc" } " is an assoc which combines a hash table and a dlist to form a structure which has the insertion and retrieval characteristics of a hash table, but with the ability to get the items in insertion order."
+"A " { $emphasis "linked assoc" } " is an assoc which combines an underlying assoc with a dlist to form a structure which has the insertion and retrieval characteristics of the underlying assoc (typically a hashtable), but with the ability to get the entries in insertion order by calling " { $link >alist } "."
$nl
-"Linked assocs implement the following methods from the assoc protocol:"
-{ $subsection at* }
-{ $subsection assoc-size }
-{ $subsection >alist }
-{ $subsection set-at }
-{ $subsection delete-at }
-{ $subsection clear-assoc }
-{ $subsection >alist } ;
+"Linked assocs are implemented in the " { $vocab-link "linked-assocs" } " vocabulary."
+{ $subsection linked-assoc }
+{ $subsection <linked-hash> }
+{ $subsection <linked-assoc> } ;
ABOUT: "linked-assocs"
\ No newline at end of file
diff --git a/basis/linked-assocs/linked-assocs.factor b/basis/linked-assocs/linked-assocs.factor
index 54f4be7269..7330ac1a56 100644
--- a/basis/linked-assocs/linked-assocs.factor
+++ b/basis/linked-assocs/linked-assocs.factor
@@ -1,12 +1,15 @@
! Copyright (C) 2008 Slava Pestov, James Cash.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs arrays kernel deques dlists sequences hashtables fry ;
+USING: accessors assocs arrays kernel deques dlists sequences fry ;
IN: linked-assocs
TUPLE: linked-assoc assoc dlist ;
+: <linked-assoc> ( exemplar -- assoc )
+ 0 swap new-assoc <dlist> linked-assoc boa ;
+
: <linked-hash> ( -- assoc )
- 0 <hashtable> <dlist> linked-assoc boa ;
+ H{ } <linked-assoc> ;
M: linked-assoc assoc-size assoc>> assoc-size ;
From 26f309d2aed640860d8dbc5e813eaa35fa05b1e8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 11 Nov 2008 18:46:31 -0600
Subject: [PATCH 024/157] Trying to make PEGs compile faster by reducing the
number of low level IR nodes: merge functionality of #>r and #r> into
#shuffle, and generate 1 node instead of 3 for calls to get-local
---
basis/compiler/cfg/builder/builder.factor | 21 +++-----
basis/compiler/cfg/stacks/stacks.factor | 20 ++++++--
basis/compiler/tree/checker/checker.factor | 18 ++-----
.../tree/dead-code/branches/branches.factor | 2 +-
.../tree/dead-code/simple/simple.factor | 26 +++-------
basis/compiler/tree/debugger/debugger.factor | 48 ++++++++++++++-----
basis/compiler/tree/def-use/def-use.factor | 4 +-
.../tree/finalization/finalization.factor | 8 ++--
.../tree/identities/identities.factor | 2 +-
.../normalization/renaming/renaming.factor | 6 +--
basis/compiler/tree/tree.factor | 38 +++++----------
.../tree/tuple-unboxing/tuple-unboxing.factor | 14 ++----
basis/locals/locals.factor | 10 ++--
.../known-words/known-words.factor | 38 ++++++++++-----
.../stack-checker/visitor/dummy/dummy.factor | 2 +-
basis/stack-checker/visitor/visitor.factor | 2 +-
16 files changed, 124 insertions(+), 135 deletions(-)
diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 17a5942af2..77ed04f4b3 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -221,21 +221,14 @@ M: #push emit-node
literal>> ^^load-literal ds-push iterate-next ;
! #shuffle
-: emit-shuffle ( effect -- )
- [ out>> ] [ in>> dup length ds-load zip ] bi
- '[ _ at ] map ds-store ;
-
M: #shuffle emit-node
- shuffle-effect emit-shuffle iterate-next ;
-
-M: #>r emit-node
- [ in-d>> length ] [ out-r>> empty? ] bi
- [ neg ##inc-d ] [ ds-load rs-store ] if
- iterate-next ;
-
-M: #r> emit-node
- [ in-r>> length ] [ out-d>> empty? ] bi
- [ neg ##inc-r ] [ rs-load ds-store ] if
+ dup
+ H{ } clone
+ [ [ in-d>> [ length ds-load ] keep ] dip '[ _ set-at ] 2each ]
+ [ [ in-r>> [ length rs-load ] keep ] dip '[ _ set-at ] 2each ]
+ [ nip ] 2tri
+ [ [ [ out-d>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map ds-store ]
+ [ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi
iterate-next ;
! #return
diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor
index f138f673e0..c8fcae87c0 100755
--- a/basis/compiler/cfg/stacks/stacks.factor
+++ b/basis/compiler/cfg/stacks/stacks.factor
@@ -15,16 +15,28 @@ IN: compiler.cfg.stacks
1 ##inc-d D 0 ##replace ;
: ds-load ( n -- vregs )
- [ <reversed> [ <ds-loc> ^^peek ] map ] [ neg ##inc-d ] bi ;
+ dup 0 =
+ [ drop f ]
+ [ [ <reversed> [ <ds-loc> ^^peek ] map ] [ neg ##inc-d ] bi ] if ;
: ds-store ( vregs -- )
- <reversed> [ length ##inc-d ] [ [ <ds-loc> ##replace ] each-index ] bi ;
+ [
+ <reversed>
+ [ length ##inc-d ]
+ [ [ <ds-loc> ##replace ] each-index ] bi
+ ] unless-empty ;
: rs-load ( n -- vregs )
- [ <reversed> [ <rs-loc> ^^peek ] map ] [ neg ##inc-r ] bi ;
+ dup 0 =
+ [ drop f ]
+ [ [ <reversed> [ <rs-loc> ^^peek ] map ] [ neg ##inc-r ] bi ] if ;
: rs-store ( vregs -- )
- <reversed> [ length ##inc-r ] [ [ <rs-loc> ##replace ] each-index ] bi ;
+ [
+ <reversed>
+ [ length ##inc-r ]
+ [ [ <rs-loc> ##replace ] each-index ] bi
+ ] unless-empty ;
: 2inputs ( -- vreg1 vreg2 )
D 1 ^^peek D 0 ^^peek -2 ##inc-d ;
diff --git a/basis/compiler/tree/checker/checker.factor b/basis/compiler/tree/checker/checker.factor
index b712a6e354..4f99fa015d 100644
--- a/basis/compiler/tree/checker/checker.factor
+++ b/basis/compiler/tree/checker/checker.factor
@@ -22,8 +22,8 @@ ERROR: check-use-error value message ;
GENERIC: check-node* ( node -- )
M: #shuffle check-node*
- [ [ mapping>> values ] [ in-d>> ] bi subset? [ "Bad mapping inputs" throw ] unless ]
- [ [ mapping>> keys ] [ out-d>> ] bi set= [ "Bad mapping outputs" throw ] unless ]
+ [ [ mapping>> values ] [ [ in-d>> ] [ in-r>> ] bi append ] bi subset? [ "Bad mapping inputs" throw ] unless ]
+ [ [ mapping>> keys ] [ [ out-d>> ] [ out-r>> ] bi append ] bi set= [ "Bad mapping outputs" throw ] unless ]
bi ;
: check-lengths ( seq -- )
@@ -31,13 +31,6 @@ M: #shuffle check-node*
M: #copy check-node* inputs/outputs 2array check-lengths ;
-: check->r/r> ( node -- )
- inputs/outputs [ drop ] [ 2array check-lengths ] if-empty ;
-
-M: #>r check-node* check->r/r> ;
-
-M: #r> check-node* check->r/r> ;
-
M: #return-recursive check-node* inputs/outputs 2array check-lengths ;
M: #phi check-node*
@@ -113,11 +106,8 @@ M: #push check-stack-flow* check-out-d ;
M: #call check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
-M: #shuffle check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
-
-M: #>r check-stack-flow* [ check-in-d ] [ check-out-r ] bi ;
-
-M: #r> check-stack-flow* [ check-in-r ] [ check-out-d ] bi ;
+M: #shuffle check-stack-flow*
+ { [ check-in-d ] [ check-in-r ] [ check-out-d ] [ check-out-r ] } cleave ;
: assert-datastack-empty ( -- )
datastack get empty? [ "Data stack not empty" throw ] unless ;
diff --git a/basis/compiler/tree/dead-code/branches/branches.factor b/basis/compiler/tree/dead-code/branches/branches.factor
index 719c80f911..eba82384ab 100644
--- a/basis/compiler/tree/dead-code/branches/branches.factor
+++ b/basis/compiler/tree/dead-code/branches/branches.factor
@@ -39,7 +39,7 @@ M: #branch remove-dead-code*
[ drop filter-live ] [ swap nths ] 2bi
[ make-values ] keep
[ drop ] [ zip ] 2bi
- #shuffle ;
+ #data-shuffle ;
: insert-drops ( nodes values indices -- nodes' )
'[
diff --git a/basis/compiler/tree/dead-code/simple/simple.factor b/basis/compiler/tree/dead-code/simple/simple.factor
index addb13ced3..185c776c4e 100644
--- a/basis/compiler/tree/dead-code/simple/simple.factor
+++ b/basis/compiler/tree/dead-code/simple/simple.factor
@@ -39,12 +39,6 @@ M: #copy compute-live-values*
M: #call compute-live-values* nip look-at-inputs ;
-M: #>r compute-live-values*
- [ out-r>> ] [ in-d>> ] bi look-at-mapping ;
-
-M: #r> compute-live-values*
- [ out-d>> ] [ in-r>> ] bi look-at-mapping ;
-
M: #shuffle compute-live-values*
mapping>> at look-at-value ;
@@ -61,7 +55,7 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
zip filter-mapping values ;
: filter-live ( values -- values' )
- [ live-value? ] filter ;
+ dup empty? [ [ live-value? ] filter ] unless ;
:: drop-values ( inputs outputs mapping-keys mapping-values -- #shuffle )
inputs
@@ -69,7 +63,7 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
outputs
mapping-keys
mapping-values
- filter-corresponding zip #shuffle ; inline
+ filter-corresponding zip #data-shuffle ; inline
:: drop-dead-values ( outputs -- #shuffle )
[let* | new-outputs [ outputs make-values ]
@@ -95,16 +89,6 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
M: #introduce remove-dead-code* ( #introduce -- nodes )
maybe-drop-dead-outputs ;
-M: #>r remove-dead-code*
- [ filter-live ] change-out-r
- [ filter-live ] change-in-d
- dup in-d>> empty? [ drop f ] when ;
-
-M: #r> remove-dead-code*
- [ filter-live ] change-out-d
- [ filter-live ] change-in-r
- dup in-r>> empty? [ drop f ] when ;
-
M: #push remove-dead-code*
dup out-d>> first live-value? [ drop f ] unless ;
@@ -125,12 +109,14 @@ M: #call remove-dead-code*
M: #shuffle remove-dead-code*
[ filter-live ] change-in-d
[ filter-live ] change-out-d
+ [ filter-live ] change-in-r
+ [ filter-live ] change-out-r
[ filter-mapping ] change-mapping
- dup in-d>> empty? [ drop f ] when ;
+ dup [ in-d>> empty? ] [ in-r>> empty? ] bi and [ drop f ] when ;
M: #copy remove-dead-code*
[ in-d>> ] [ out-d>> ] bi
- 2dup swap zip #shuffle
+ 2dup swap zip #data-shuffle
remove-dead-code* ;
M: #terminate remove-dead-code*
diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor
index 59a028a4f4..214be18148 100644
--- a/basis/compiler/tree/debugger/debugger.factor
+++ b/basis/compiler/tree/debugger/debugger.factor
@@ -3,7 +3,7 @@
USING: kernel assocs match fry accessors namespaces make effects
sequences sequences.private quotations generic macros arrays
prettyprint prettyprint.backend prettyprint.sections math words
-combinators io sorting hints qualified
+combinators combinators.short-circuit io sorting hints qualified
compiler.tree
compiler.tree.recursive
compiler.tree.normalization
@@ -57,9 +57,41 @@ TUPLE: shuffle-node { effect effect } ;
M: shuffle-node pprint* effect>> effect>string text ;
+: (shuffle-effect) ( in out #shuffle -- effect )
+ mapping>> '[ _ at ] map <effect> ;
+
+: shuffle-effect ( #shuffle -- effect )
+ [ in-d>> ] [ out-d>> ] [ ] tri (shuffle-effect) ;
+
+: #>r? ( #shuffle -- ? )
+ {
+ [ in-d>> length 1 = ]
+ [ out-r>> length 1 = ]
+ [ in-r>> empty? ]
+ [ out-d>> empty? ]
+ } 1&& ;
+
+: #r>? ( #shuffle -- ? )
+ {
+ [ in-d>> empty? ]
+ [ out-r>> empty? ]
+ [ in-r>> length 1 = ]
+ [ out-d>> length 1 = ]
+ } 1&& ;
+
M: #shuffle node>quot
- shuffle-effect dup pretty-shuffle
- [ % ] [ shuffle-node boa , ] ?if ;
+ {
+ { [ dup #>r? ] [ drop \ >r , ] }
+ { [ dup #r>? ] [ drop \ r> , ] }
+ {
+ [ dup [ in-r>> empty? ] [ out-r>> empty? ] bi and ]
+ [
+ dup shuffle-effect pretty-shuffle
+ [ % ] [ shuffle-node boa , ] ?if
+ ]
+ }
+ [ drop "COMPLEX SHUFFLE" , ]
+ } cond ;
M: #push node>quot literal>> , ;
@@ -82,16 +114,6 @@ M: #if node>quot
M: #dispatch node>quot
children>> [ nodes>quot ] map , \ dispatch , ;
-M: #>r node>quot
- [ in-d>> length ] [ out-r>> empty? \ drop \ >r ? ] bi
- <repetition> % ;
-
-DEFER: rdrop
-
-M: #r> node>quot
- [ in-r>> length ] [ out-d>> empty? \ rdrop \ r> ? ] bi
- <repetition> % ;
-
M: #alien-invoke node>quot params>> , \ #alien-invoke , ;
M: #alien-indirect node>quot params>> , \ #alien-indirect , ;
diff --git a/basis/compiler/tree/def-use/def-use.factor b/basis/compiler/tree/def-use/def-use.factor
index 2379f3918d..9be9f13043 100644
--- a/basis/compiler/tree/def-use/def-use.factor
+++ b/basis/compiler/tree/def-use/def-use.factor
@@ -38,16 +38,16 @@ GENERIC: node-uses-values ( node -- values )
M: #introduce node-uses-values drop f ;
M: #push node-uses-values drop f ;
-M: #r> node-uses-values in-r>> ;
M: #phi node-uses-values phi-in-d>> concat remove-bottom prune ;
M: #declare node-uses-values declaration>> keys ;
M: #terminate node-uses-values [ in-d>> ] [ in-r>> ] bi append ;
+M: #shuffle node-uses-values [ in-d>> ] [ in-r>> ] bi append ;
M: #alien-callback node-uses-values drop f ;
M: node node-uses-values in-d>> ;
GENERIC: node-defs-values ( node -- values )
-M: #>r node-defs-values out-r>> ;
+M: #shuffle node-defs-values [ out-d>> ] [ out-r>> ] bi append ;
M: #branch node-defs-values drop f ;
M: #declare node-defs-values drop f ;
M: #return node-defs-values drop f ;
diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor
index 2d2e429994..16a27e020a 100644
--- a/basis/compiler/tree/finalization/finalization.factor
+++ b/basis/compiler/tree/finalization/finalization.factor
@@ -1,6 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences words memoize classes.builtin
+fry assocs
compiler.tree
compiler.tree.combinators
compiler.tree.propagation.info
@@ -27,9 +28,10 @@ GENERIC: finalize* ( node -- nodes )
M: #copy finalize* drop f ;
M: #shuffle finalize*
- dup shuffle-effect
- [ in>> ] [ out>> ] bi sequence=
- [ drop f ] when ;
+ dup
+ [ [ in-d>> ] [ out-d>> ] [ mapping>> ] tri '[ _ at ] map sequence= ]
+ [ [ in-r>> ] [ out-r>> ] [ mapping>> ] tri '[ _ at ] map sequence= ]
+ bi and [ drop f ] when ;
: builtin-predicate? ( #call -- ? )
word>> "predicating" word-prop builtin-class? ;
diff --git a/basis/compiler/tree/identities/identities.factor b/basis/compiler/tree/identities/identities.factor
index d6ed59cbaa..00632ec6f6 100644
--- a/basis/compiler/tree/identities/identities.factor
+++ b/basis/compiler/tree/identities/identities.factor
@@ -79,7 +79,7 @@ GENERIC: apply-identities* ( node -- node )
: select-input ( node n -- #shuffle )
[ [ in-d>> ] [ out-d>> ] bi ] dip
- pick nth over first associate #shuffle ;
+ pick nth over first associate #data-shuffle ;
M: #call apply-identities*
dup word>> "identities" word-prop [
diff --git a/basis/compiler/tree/normalization/renaming/renaming.factor b/basis/compiler/tree/normalization/renaming/renaming.factor
index 3050df2611..9d68f4a733 100644
--- a/basis/compiler/tree/normalization/renaming/renaming.factor
+++ b/basis/compiler/tree/normalization/renaming/renaming.factor
@@ -10,7 +10,7 @@ SYMBOL: rename-map
[ rename-map get at ] keep or ;
: rename-values ( values -- values' )
- rename-map get '[ [ _ at ] keep or ] map ;
+ dup empty? [ rename-map get '[ [ _ at ] keep or ] map ] unless ;
: add-renamings ( old new -- )
[ rename-values ] dip
@@ -22,13 +22,11 @@ M: #introduce rename-node-values* ;
M: #shuffle rename-node-values*
[ rename-values ] change-in-d
+ [ rename-values ] change-in-r
[ [ rename-value ] assoc-map ] change-mapping ;
M: #push rename-node-values* ;
-M: #r> rename-node-values*
- [ rename-values ] change-in-r ;
-
M: #terminate rename-node-values*
[ rename-values ] change-in-d
[ rename-values ] change-in-r ;
diff --git a/basis/compiler/tree/tree.factor b/basis/compiler/tree/tree.factor
index 05f33902ec..9f9a43df64 100644
--- a/basis/compiler/tree/tree.factor
+++ b/basis/compiler/tree/tree.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry arrays generic assocs kernel math namespaces parser
-sequences words vectors math.intervals effects classes
+sequences words vectors math.intervals classes
accessors combinators stack-checker.state stack-checker.visitor
stack-checker.inlining ;
IN: compiler.tree
@@ -42,30 +42,21 @@ TUPLE: #push < node literal out-d ;
TUPLE: #renaming < node ;
-TUPLE: #shuffle < #renaming mapping in-d out-d ;
+TUPLE: #shuffle < #renaming mapping in-d out-d in-r out-r ;
-: #shuffle ( inputs outputs mapping -- node )
+: #shuffle ( in-d out-d in-r out-r mapping -- node )
\ #shuffle new
swap >>mapping
+ swap >>out-r
+ swap >>in-r
swap >>out-d
swap >>in-d ;
+: #data-shuffle ( in-d out-d mapping -- node )
+ [ f f ] dip #shuffle ; inline
+
: #drop ( inputs -- node )
- { } { } #shuffle ;
-
-TUPLE: #>r < #renaming in-d out-r ;
-
-: #>r ( inputs outputs -- node )
- \ #>r new
- swap >>out-r
- swap >>in-d ;
-
-TUPLE: #r> < #renaming in-r out-d ;
-
-: #r> ( inputs outputs -- node )
- \ #r> new
- swap >>out-d
- swap >>in-r ;
+ { } { } #data-shuffle ;
TUPLE: #terminate < node in-d in-r ;
@@ -171,16 +162,9 @@ TUPLE: #alien-callback < #alien-node ;
GENERIC: inputs/outputs ( #renaming -- inputs outputs )
M: #shuffle inputs/outputs mapping>> unzip swap ;
-M: #>r inputs/outputs [ in-d>> ] [ out-r>> ] bi ;
-M: #r> inputs/outputs [ in-r>> ] [ out-d>> ] bi ;
M: #copy inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
-: shuffle-effect ( #shuffle -- effect )
- [ in-d>> ] [ out-d>> ] [ mapping>> ] tri
- '[ _ at ] map
- <effect> ;
-
: recursive-phi-in ( #enter-recursive -- seq )
[ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
@@ -193,8 +177,8 @@ M: vector #call, #call node, ;
M: vector #push, #push node, ;
M: vector #shuffle, #shuffle node, ;
M: vector #drop, #drop node, ;
-M: vector #>r, #>r node, ;
-M: vector #r>, #r> node, ;
+M: vector #>r, [ [ f f ] dip ] [ swap zip ] 2bi #shuffle, ;
+M: vector #r>, [ swap [ f swap ] dip f ] [ swap zip ] 2bi #shuffle, ;
M: vector #return, #return node, ;
M: vector #enter-recursive, #enter-recursive node, ;
M: vector #return-recursive, #return-recursive node, ;
diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor
index 8e07c08194..52903fce8d 100644
--- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor
+++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor
@@ -42,7 +42,7 @@ M: #push unbox-tuples* ( #push -- nodes )
[ dup unboxed-allocation [ (flatten-values) ] [ ] ?if ] map ;
: flatten-values ( values -- values' )
- (flatten-values) flatten ;
+ dup empty? [ (flatten-values) flatten ] unless ;
: prepare-slot-access ( #call -- tuple-values outputs slot-values )
[ in-d>> flatten-values ]
@@ -54,7 +54,7 @@ M: #push unbox-tuples* ( #push -- nodes )
] tri ;
: slot-access-shuffle ( tuple-values outputs slot-values -- #shuffle )
- [ drop ] [ zip ] 2bi #shuffle ;
+ [ drop ] [ zip ] 2bi #data-shuffle ;
: unbox-slot-access ( #call -- nodes )
dup out-d>> first unboxed-slot-access? [
@@ -77,17 +77,11 @@ M: #copy unbox-tuples*
[ flatten-values ] change-in-d
[ flatten-values ] change-out-d ;
-M: #>r unbox-tuples*
- [ flatten-values ] change-in-d
- [ flatten-values ] change-out-r ;
-
-M: #r> unbox-tuples*
- [ flatten-values ] change-in-r
- [ flatten-values ] change-out-d ;
-
M: #shuffle unbox-tuples*
[ flatten-values ] change-in-d
[ flatten-values ] change-out-d
+ [ flatten-values ] change-in-r
+ [ flatten-values ] change-out-r
[ unzip [ flatten-values ] bi@ zip ] change-mapping ;
M: #terminate unbox-tuples*
diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor
index c588269284..e74ecf3dc9 100644
--- a/basis/locals/locals.factor
+++ b/basis/locals/locals.factor
@@ -6,8 +6,7 @@ quotations debugger macros arrays macros splitting combinators
prettyprint.backend definitions prettyprint hashtables
prettyprint.sections sets sequences.private effects
effects.parser generic generic.parser compiler.units accessors
-locals.backend memoize macros.expander lexer classes
-stack-checker.known-words ;
+locals.backend memoize macros.expander lexer classes ;
IN: locals
! Inspired by
@@ -49,8 +48,7 @@ PREDICATE: local < word "local?" word-prop ;
: <local> ( name -- word )
#! Create a local variable identifier
f <word>
- dup t "local?" set-word-prop
- dup { } { object } define-primitive ;
+ dup t "local?" set-word-prop ;
PREDICATE: local-word < word "local-word?" word-prop ;
@@ -61,14 +59,12 @@ PREDICATE: local-reader < word "local-reader?" word-prop ;
: <local-reader> ( name -- word )
f <word>
- dup t "local-reader?" set-word-prop
- dup { } { object } define-primitive ;
+ dup t "local-reader?" set-word-prop ;
PREDICATE: local-writer < word "local-writer?" word-prop ;
: <local-writer> ( reader -- word )
dup name>> "!" append f <word> {
- [ nip { object } { } define-primitive ]
[ nip t "local-writer?" set-word-prop ]
[ swap "local-reader" set-word-prop ]
[ "local-writer" set-word-prop ]
diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index c40b94fd3c..257181f6ad 100644
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -10,7 +10,8 @@ sequences sequences.private slots.private strings
strings.private system threads.private classes.tuple
classes.tuple.private vectors vectors.private words definitions
words.private assocs summary compiler.units system.private
-combinators locals.backend words.private quotations.private
+combinators locals locals.backend locals.private words.private
+quotations.private
stack-checker.state
stack-checker.backend
stack-checker.branches
@@ -48,7 +49,7 @@ IN: stack-checker.known-words
: infer-shuffle ( shuffle -- )
[ in>> length consume-d ] keep ! inputs shuffle
[ drop ] [ shuffle dup copy-values dup output-d ] 2bi ! inputs outputs copies
- [ nip ] [ swap zip ] 2bi ! inputs copies mapping
+ [ nip f f ] [ swap zip ] 2bi ! in-d out-d in-r out-r mapping
#shuffle, ;
: infer-shuffle-word ( word -- )
@@ -123,21 +124,23 @@ M: object infer-call*
: infer-load-locals ( -- )
pop-literal nip
- [ dup reverse <effect> infer-shuffle ]
- [ infer->r ]
- bi ;
+ consume-d dup reverse copy-values dup output-r
+ [ [ f f ] dip ] [ reverse swap zip ] 2bi #shuffle, ;
: infer-get-local ( -- )
- pop-literal nip
- [ infer-r> ]
- [ dup 0 prefix <effect> infer-shuffle ]
- [ infer->r ]
- tri ;
+ [let* | n [ pop-literal nip ]
+ in-r [ n consume-r ]
+ out-d [ in-r first copy-value 1array ]
+ out-r [ in-r copy-values ] |
+ out-d output-d
+ out-r output-r
+ f out-d in-r out-r
+ out-r in-r zip out-d first in-r first 2array suffix
+ #shuffle,
+ ] ;
: infer-drop-locals ( -- )
- pop-literal nip
- [ infer-r> ]
- [ { } <effect> infer-shuffle ] bi ;
+ f f pop-literal nip consume-r f f #shuffle, ;
: infer-special ( word -- )
{
@@ -164,6 +167,12 @@ M: object infer-call*
{ \ alien-callback [ infer-alien-callback ] }
} case ;
+: infer-local-reader ( word -- )
+ (( -- value )) apply-word/effect ;
+
+: infer-local-writer ( word -- )
+ (( value -- )) apply-word/effect ;
+
{
>r r> declare call (call) curry compose execute (execute) if
dispatch <tuple-boa> (throw) load-locals get-local drop-locals
@@ -183,6 +192,9 @@ do-primitive alien-invoke alien-indirect alien-callback
{ [ dup "macro" word-prop ] [ apply-macro ] }
{ [ dup "cannot-infer" word-prop ] [ cannot-infer-effect ] }
{ [ dup "inferred-effect" word-prop ] [ cached-infer ] }
+ { [ dup local? ] [ infer-local-reader ] }
+ { [ dup local-reader? ] [ infer-local-reader ] }
+ { [ dup local-writer? ] [ infer-local-writer ] }
{ [ dup recursive-label ] [ call-recursive-word ] }
[ dup infer-word apply-word/effect ]
} cond ;
diff --git a/basis/stack-checker/visitor/dummy/dummy.factor b/basis/stack-checker/visitor/dummy/dummy.factor
index a24d8e226d..5f05d97d1a 100644
--- a/basis/stack-checker/visitor/dummy/dummy.factor
+++ b/basis/stack-checker/visitor/dummy/dummy.factor
@@ -8,7 +8,7 @@ M: f #introduce, drop ;
M: f #call, 3drop ;
M: f #call-recursive, 3drop ;
M: f #push, 2drop ;
-M: f #shuffle, 3drop ;
+M: f #shuffle, 2drop 2drop drop ;
M: f #>r, 2drop ;
M: f #r>, 2drop ;
M: f #return, drop ;
diff --git a/basis/stack-checker/visitor/visitor.factor b/basis/stack-checker/visitor/visitor.factor
index 7d8ec90453..6093cd008a 100644
--- a/basis/stack-checker/visitor/visitor.factor
+++ b/basis/stack-checker/visitor/visitor.factor
@@ -13,7 +13,7 @@ HOOK: #introduce, stack-visitor ( values -- )
HOOK: #call, stack-visitor ( inputs outputs word -- )
HOOK: #call-recursive, stack-visitor ( inputs outputs word -- )
HOOK: #push, stack-visitor ( literal value -- )
-HOOK: #shuffle, stack-visitor ( inputs outputs mapping -- )
+HOOK: #shuffle, stack-visitor ( in-d out-d in-r out-r mapping -- )
HOOK: #drop, stack-visitor ( values -- )
HOOK: #>r, stack-visitor ( inputs outputs -- )
HOOK: #r>, stack-visitor ( inputs outputs -- )
From d970a632bb3f1e210704d465629ff67ac2bfc6f8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 11 Nov 2008 19:51:12 -0600
Subject: [PATCH 025/157] Fix nodes>quot
---
basis/compiler/tree/debugger/debugger.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor
index 214be18148..a1d8773484 100644
--- a/basis/compiler/tree/debugger/debugger.factor
+++ b/basis/compiler/tree/debugger/debugger.factor
@@ -86,7 +86,7 @@ M: #shuffle node>quot
{
[ dup [ in-r>> empty? ] [ out-r>> empty? ] bi and ]
[
- dup shuffle-effect pretty-shuffle
+ shuffle-effect dup pretty-shuffle
[ % ] [ shuffle-node boa , ] ?if
]
}
From fab60f94a7b86f5bb77ac46d2926b6bbf6600d8e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 11 Nov 2008 19:51:26 -0600
Subject: [PATCH 026/157] Minor performance improvements
---
.../backend/backend-tests.factor | 22 +++++++++++++++
basis/stack-checker/backend/backend.factor | 27 ++++++++++++++-----
2 files changed, 42 insertions(+), 7 deletions(-)
create mode 100644 basis/stack-checker/backend/backend-tests.factor
diff --git a/basis/stack-checker/backend/backend-tests.factor b/basis/stack-checker/backend/backend-tests.factor
new file mode 100644
index 0000000000..3bbba0fcb8
--- /dev/null
+++ b/basis/stack-checker/backend/backend-tests.factor
@@ -0,0 +1,22 @@
+USING: stack-checker.backend tools.test kernel namespaces
+stack-checker.state sequences ;
+IN: stack-checker.backend.tests
+
+[ ] [
+ V{ } clone meta-d set
+ V{ } clone meta-r set
+ 0 d-in set
+] unit-test
+
+[ 0 ] [ 0 ensure-d length ] unit-test
+
+[ 2 ] [ 2 ensure-d length ] unit-test
+[ 2 ] [ meta-d get length ] unit-test
+
+[ 3 ] [ 3 ensure-d length ] unit-test
+[ 3 ] [ meta-d get length ] unit-test
+
+[ 1 ] [ 1 ensure-d length ] unit-test
+[ 3 ] [ meta-d get length ] unit-test
+
+[ ] [ 1 consume-d drop ] unit-test
diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor
index f8dec5f823..aadd1adbd4 100644
--- a/basis/stack-checker/backend/backend.factor
+++ b/basis/stack-checker/backend/backend.factor
@@ -17,15 +17,25 @@ IN: stack-checker.backend
: peek-d ( -- obj ) pop-d dup push-d ;
-: consume-d ( n -- seq ) [ pop-d ] replicate reverse ;
-
-: output-d ( values -- ) meta-d get push-all ;
-
-: ensure-d ( n -- values ) consume-d dup output-d ;
-
: make-values ( n -- values )
[ <value> ] replicate ;
+: ensure-d ( n -- values )
+ meta-d get 2dup length > [
+ 2dup
+ [ nip >array ] [ length - make-values ] [ nip delete-all ] 2tri
+ [ length d-in +@ ] [ #introduce, ] [ meta-d get push-all ] tri
+ meta-d get push-all
+ ] when swap tail* ;
+
+: shorten-by ( n seq -- )
+ [ length swap - ] keep shorten ; inline
+
+: consume-d ( n -- seq )
+ [ ensure-d ] [ meta-d get shorten-by ] bi ;
+
+: output-d ( values -- ) meta-d get push-all ;
+
: produce-d ( n -- values )
make-values dup meta-d get push-all ;
@@ -35,7 +45,10 @@ IN: stack-checker.backend
meta-r get dup empty?
[ too-many-r> inference-error ] [ pop ] if ;
-: consume-r ( n -- seq ) [ pop-r ] replicate reverse ;
+: consume-r ( n -- seq )
+ meta-r get 2dup length >
+ [ too-many-r> inference-error ] when
+ [ swap tail* ] [ shorten-by ] 2bi ;
: output-r ( seq -- ) meta-r get push-all ;
From 70b1f7346696aa1247b76dd8ed58613225241dea Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Tue, 11 Nov 2008 21:20:51 -0500
Subject: [PATCH 027/157] Changing name in advice docs to pass help-lint test
---
extra/advice/advice-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/advice/advice-docs.factor b/extra/advice/advice-docs.factor
index 2c470d04b3..0a5d5f8703 100644
--- a/extra/advice/advice-docs.factor
+++ b/extra/advice/advice-docs.factor
@@ -17,7 +17,7 @@ HELP: advised?
{ $description "Determines whether or not the given word has any advice on it." } ;
HELP: ad-do-it
-{ $values { "input" "an object" } { "output" "an object" } }
+{ $values { "input" "an object" } { "result" "an object" } }
{ $description "Calls either the next applicable around advice or the main body, returning back to the point it was called from when finished. This word should only be called from inside advice." }
{ $see-also coyield } ;
From c97e731d4425b4533ec590cba18c6d5c7cb93c0b Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Tue, 11 Nov 2008 21:25:33 -0500
Subject: [PATCH 028/157] Fixing linked-assoc docs
---
basis/linked-assocs/linked-assocs-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/linked-assocs/linked-assocs-docs.factor b/basis/linked-assocs/linked-assocs-docs.factor
index 31f387aeb9..6fd42954aa 100644
--- a/basis/linked-assocs/linked-assocs-docs.factor
+++ b/basis/linked-assocs/linked-assocs-docs.factor
@@ -5,7 +5,7 @@ HELP: linked-assoc
{ $class-description "The class of linked assocs. Linked assoc are implemented by combining an assoc with a dlist. The assoc is used for lookup and retrieval of single values, while the dlist is used for getting lists of keys/values, which will be in insertion order." } ;
HELP: <linked-assoc>
-{ $values { "exemplar" "an exemplar assoc" } }
+{ $values { "exemplar" "an exemplar assoc" } { "assoc" linked-assoc } }
{ $description "Creates an empty linked assoc backed by a new instance of the same type as the exemplar." } ;
HELP: <linked-hash>
From ed3a81a503c182c914ceab1926ff1098b33d7a67 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 11 Nov 2008 23:03:50 -0600
Subject: [PATCH 029/157] Faster M: hashtable >alist performs less dispatch and
allocates less junk
---
basis/compiler/compiler.factor | 2 +-
{core => basis}/grouping/authors.txt | 0
{core => basis}/grouping/grouping-docs.factor | 0
{core => basis}/grouping/grouping-tests.factor | 0
{core => basis}/grouping/grouping.factor | 0
{core => basis}/grouping/summary.txt | 0
{core => basis}/grouping/tags.txt | 0
core/hashtables/hashtables.factor | 13 ++++++++++---
8 files changed, 11 insertions(+), 4 deletions(-)
rename {core => basis}/grouping/authors.txt (100%)
rename {core => basis}/grouping/grouping-docs.factor (100%)
rename {core => basis}/grouping/grouping-tests.factor (100%)
rename {core => basis}/grouping/grouping.factor (100%)
rename {core => basis}/grouping/summary.txt (100%)
rename {core => basis}/grouping/tags.txt (100%)
diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor
index b01a835b4a..dc25520dc4 100644
--- a/basis/compiler/compiler.factor
+++ b/basis/compiler/compiler.factor
@@ -119,7 +119,7 @@ t compile-dependencies? set-global
H{ } clone compiled set
[ queue-compile ] each
compile-queue get compile-loop
- compiled get >alist
+ compiled get >alist >array
] with-scope ;
: enable-compiler ( -- )
diff --git a/core/grouping/authors.txt b/basis/grouping/authors.txt
similarity index 100%
rename from core/grouping/authors.txt
rename to basis/grouping/authors.txt
diff --git a/core/grouping/grouping-docs.factor b/basis/grouping/grouping-docs.factor
similarity index 100%
rename from core/grouping/grouping-docs.factor
rename to basis/grouping/grouping-docs.factor
diff --git a/core/grouping/grouping-tests.factor b/basis/grouping/grouping-tests.factor
similarity index 100%
rename from core/grouping/grouping-tests.factor
rename to basis/grouping/grouping-tests.factor
diff --git a/core/grouping/grouping.factor b/basis/grouping/grouping.factor
similarity index 100%
rename from core/grouping/grouping.factor
rename to basis/grouping/grouping.factor
diff --git a/core/grouping/summary.txt b/basis/grouping/summary.txt
similarity index 100%
rename from core/grouping/summary.txt
rename to basis/grouping/summary.txt
diff --git a/core/grouping/tags.txt b/basis/grouping/tags.txt
similarity index 100%
rename from core/grouping/tags.txt
rename to basis/grouping/tags.txt
diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor
index 32fda7d2fb..0357502a8a 100644
--- a/core/hashtables/hashtables.factor
+++ b/core/hashtables/hashtables.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel kernel.private slots.private math
-assocs math.private sequences sequences.private vectors grouping ;
+assocs math.private sequences sequences.private vectors ;
IN: hashtables
TUPLE: hashtable
@@ -129,14 +129,21 @@ M: hashtable set-at ( value key hash -- )
2 <hashtable> [ set-at ] keep ;
M: hashtable >alist
- array>> 2 <groups> [ first tombstone? not ] filter ;
+ array>> [ length 2/ ] keep V{ } clone [
+ [
+ >r
+ >r 1 fixnum-shift-fast r>
+ [ array-nth ] [ >r 1 fixnum+fast r> array-nth ] 2bi r>
+ pick tombstone? [ 3drop ] [ [ 2array ] dip push ] if
+ ] 2curry each
+ ] keep ;
M: hashtable clone
(clone) [ clone ] change-array ;
M: hashtable equal?
over hashtable? [
- 2dup [ assoc-size ] bi@ number=
+ 2dup [ assoc-size ] bi@ eq?
[ assoc= ] [ 2drop f ] if
] [ 2drop f ] if ;
From 57cf756c0e53c9142e4749d851ef1293f3ce0641 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 11 Nov 2008 23:04:15 -0600
Subject: [PATCH 030/157] Use eq? instead of number= in a few places
---
core/combinators/combinators.factor | 2 +-
core/sbufs/sbufs.factor | 2 +-
core/strings/strings.factor | 2 +-
3 files changed, 3 insertions(+), 3 deletions(-)
diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor
index 577dd153a1..8cfa671a8b 100644
--- a/core/combinators/combinators.factor
+++ b/core/combinators/combinators.factor
@@ -167,6 +167,6 @@ M: slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
M: hashtable hashcode*
[
- dup assoc-size 1 number=
+ dup assoc-size 1 eq?
[ assoc-hashcode ] [ nip assoc-size ] if
] recursive-hashcode ;
diff --git a/core/sbufs/sbufs.factor b/core/sbufs/sbufs.factor
index e45d98a3df..5a30654f03 100644
--- a/core/sbufs/sbufs.factor
+++ b/core/sbufs/sbufs.factor
@@ -33,7 +33,7 @@ M: string new-resizable drop <sbuf> ;
M: string like
drop dup string? [
dup sbuf? [
- dup length over underlying>> length number= [
+ dup length over underlying>> length eq? [
underlying>> dup reset-string-hashcode
] [
>string
diff --git a/core/strings/strings.factor b/core/strings/strings.factor
index 8ff5a7caf4..944286cce5 100644
--- a/core/strings/strings.factor
+++ b/core/strings/strings.factor
@@ -20,7 +20,7 @@ PRIVATE>
M: string equal?
over string? [
- over hashcode over hashcode number=
+ over hashcode over hashcode eq?
[ sequence= ] [ 2drop f ] if
] [
2drop f
From de02724135e2e975ad9e3025a87e6144ccb03e00 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 11 Nov 2008 23:04:30 -0600
Subject: [PATCH 031/157] Make a word inline for the win
---
basis/heaps/heaps.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/heaps/heaps.factor b/basis/heaps/heaps.factor
index 6c387632ed..92146755d9 100644
--- a/basis/heaps/heaps.factor
+++ b/basis/heaps/heaps.factor
@@ -62,7 +62,7 @@ M: heap heap-size ( heap -- n )
: data-set-nth ( entry n heap -- )
>r [ >>index drop ] 2keep r>
- data>> set-nth-unsafe ;
+ data>> set-nth-unsafe ; inline
: data-push ( entry heap -- n )
dup heap-size [
From cdb94e4c623d5e56ea8a124d50adcc46e167d811 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 11 Nov 2008 23:07:40 -0600
Subject: [PATCH 032/157] Word constructor was not invoking relocation on the
profiled block, so words constructed while profiling was on could not be
executed. This prevented profiling of PEGs
---
basis/tools/profiler/profiler-tests.factor | 7 ++++++-
vm/profiler.c | 1 -
vm/types.c | 5 ++++-
3 files changed, 10 insertions(+), 3 deletions(-)
diff --git a/basis/tools/profiler/profiler-tests.factor b/basis/tools/profiler/profiler-tests.factor
index 75ca5ede8c..f0c71aa311 100644
--- a/basis/tools/profiler/profiler-tests.factor
+++ b/basis/tools/profiler/profiler-tests.factor
@@ -1,6 +1,7 @@
IN: tools.profiler.tests
USING: accessors tools.profiler tools.test kernel memory math
-threads alien tools.profiler.private sequences compiler.units ;
+threads alien tools.profiler.private sequences compiler.units
+words ;
[ t ] [
\ length counter>>
@@ -54,3 +55,7 @@ threads alien tools.profiler.private sequences compiler.units ;
] unit-test
[ 666 ] [ \ recompile-while-profiling-test counter>> ] unit-test
+
+[ ] [ [ [ ] compile-call ] profile ] unit-test
+
+[ [ gensym execute ] profile ] [ T{ undefined } = ] must-fail-with
diff --git a/vm/profiler.c b/vm/profiler.c
index 27e903178b..250e5a996a 100755
--- a/vm/profiler.c
+++ b/vm/profiler.c
@@ -32,7 +32,6 @@ F_COMPILED *compile_profiling_stub(F_WORD *word)
/* Allocates memory */
void update_word_xt(F_WORD *word)
{
- /* If we just enabled the profiler, reset call count */
if(profiling_p)
{
if(!word->profiling)
diff --git a/vm/types.c b/vm/types.c
index 5e2ed4bed9..38fe3460e7 100755
--- a/vm/types.c
+++ b/vm/types.c
@@ -61,6 +61,9 @@ F_WORD *allot_word(CELL vocab, CELL name)
update_word_xt(word);
UNREGISTER_UNTAGGED(word);
+ if(profiling_p)
+ iterate_code_heap_step(word->profiling,relocate_code_block);
+
return word;
}
@@ -76,7 +79,7 @@ DEFINE_PRIMITIVE(word)
DEFINE_PRIMITIVE(word_xt)
{
F_WORD *word = untag_word(dpop());
- F_COMPILED *code = word->code;
+ F_COMPILED *code = (profiling_p ? word->profiling : word->code);
dpush(allot_cell((CELL)code + sizeof(F_COMPILED)));
dpush(allot_cell((CELL)code + sizeof(F_COMPILED) + code->code_length));
}
From eed1dd3d2b123fd6d6d633378232ca29d52e4e2e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 11 Nov 2008 23:38:19 -0600
Subject: [PATCH 033/157] Fix byte vector prettyprinting
---
basis/prettyprint/backend/backend.factor | 1 +
core/byte-vectors/byte-vectors-tests.factor | 5 ++++-
2 files changed, 5 insertions(+), 1 deletion(-)
diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor
index b749bd63eb..31b6ba3f26 100644
--- a/basis/prettyprint/backend/backend.factor
+++ b/basis/prettyprint/backend/backend.factor
@@ -214,6 +214,7 @@ M: tuple pprint-narrow? drop t ;
M: object pprint* pprint-object ;
M: vector pprint* pprint-object ;
+M: byte-vector pprint* pprint-object ;
M: hashtable pprint* pprint-object ;
M: curry pprint*
diff --git a/core/byte-vectors/byte-vectors-tests.factor b/core/byte-vectors/byte-vectors-tests.factor
index d457d6805e..9a100d9795 100644
--- a/core/byte-vectors/byte-vectors-tests.factor
+++ b/core/byte-vectors/byte-vectors-tests.factor
@@ -1,5 +1,6 @@
IN: byte-vectors.tests
-USING: tools.test byte-vectors vectors sequences kernel ;
+USING: tools.test byte-vectors vectors sequences kernel
+prettyprint ;
[ 0 ] [ 123 <byte-vector> length ] unit-test
@@ -12,3 +13,5 @@ USING: tools.test byte-vectors vectors sequences kernel ;
] unit-test
[ t ] [ BV{ } byte-vector? ] unit-test
+
+[ "BV{ }" ] [ BV{ } unparse ] unit-test
From 9f52ee50b01c2bafe0603ca9c28f5dbcc3ba77ff Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 12 Nov 2008 00:10:50 -0600
Subject: [PATCH 034/157] Another speedup to >alist: create vector with right
size up-front. 10 second bootstrap time reduction
---
basis/compiler/compiler.factor | 2 +-
core/hashtables/hashtables.factor | 16 +++++++++++++---
2 files changed, 14 insertions(+), 4 deletions(-)
diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor
index dc25520dc4..b01a835b4a 100644
--- a/basis/compiler/compiler.factor
+++ b/basis/compiler/compiler.factor
@@ -119,7 +119,7 @@ t compile-dependencies? set-global
H{ } clone compiled set
[ queue-compile ] each
compile-queue get compile-loop
- compiled get >alist >array
+ compiled get >alist
] with-scope ;
: enable-compiler ( -- )
diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor
index 0357502a8a..0fde459a25 100644
--- a/core/hashtables/hashtables.factor
+++ b/core/hashtables/hashtables.factor
@@ -128,15 +128,25 @@ M: hashtable set-at ( value key hash -- )
: associate ( value key -- hash )
2 <hashtable> [ set-at ] keep ;
+<PRIVATE
+
+: push-unsafe ( elt seq -- )
+ [ length ] keep
+ [ underlying>> set-array-nth ]
+ [ >r 1+ r> (>>length) ]
+ 2bi ; inline
+
+PRIVATE>
+
M: hashtable >alist
- array>> [ length 2/ ] keep V{ } clone [
+ [ array>> [ length 2/ ] keep ] [ assoc-size <vector> ] bi [
[
>r
>r 1 fixnum-shift-fast r>
[ array-nth ] [ >r 1 fixnum+fast r> array-nth ] 2bi r>
- pick tombstone? [ 3drop ] [ [ 2array ] dip push ] if
+ pick tombstone? [ 3drop ] [ [ 2array ] dip push-unsafe ] if
] 2curry each
- ] keep ;
+ ] keep { } like ;
M: hashtable clone
(clone) [ clone ] change-array ;
From 0d3a5e372add558955d6be991ceef47f3a6f05fd Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Wed, 12 Nov 2008 00:39:56 -0600
Subject: [PATCH 035/157] allow setting of emacsclient
---
basis/editors/emacs/emacs.factor | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/basis/editors/emacs/emacs.factor b/basis/editors/emacs/emacs.factor
index 1d9f72f8c3..eae6a3077b 100644
--- a/basis/editors/emacs/emacs.factor
+++ b/basis/editors/emacs/emacs.factor
@@ -4,12 +4,14 @@ IN: editors.emacs
: emacsclient ( file line -- )
[
- "emacsclient" ,
+ \ emacsclient get ,
"--no-wait" ,
"+" swap number>string append ,
,
] { } make try-process ;
+\ emacsclient "emacsclient" set-global
+
: emacs ( word -- )
where first2 emacsclient ;
From 44b0cf94ab99df938a5e3027350b973a342ae249 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Wed, 12 Nov 2008 01:14:19 -0600
Subject: [PATCH 036/157] better fix for emacs
---
basis/editors/emacs/emacs.factor | 4 +---
1 file changed, 1 insertion(+), 3 deletions(-)
diff --git a/basis/editors/emacs/emacs.factor b/basis/editors/emacs/emacs.factor
index eae6a3077b..1550fccc0b 100644
--- a/basis/editors/emacs/emacs.factor
+++ b/basis/editors/emacs/emacs.factor
@@ -4,14 +4,12 @@ IN: editors.emacs
: emacsclient ( file line -- )
[
- \ emacsclient get ,
+ \ emacsclient get "emacsclient" or ,
"--no-wait" ,
"+" swap number>string append ,
,
] { } make try-process ;
-\ emacsclient "emacsclient" set-global
-
: emacs ( word -- )
where first2 emacsclient ;
From 6cc08f76ddaf814d21a77f03ddddc6e18aa7def9 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Wed, 12 Nov 2008 03:58:41 -0600
Subject: [PATCH 037/157] help/handbook: Fix some headings
---
basis/help/handbook/handbook.factor | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor
index 5b60102e46..0ceedfecb9 100644
--- a/basis/help/handbook/handbook.factor
+++ b/basis/help/handbook/handbook.factor
@@ -166,16 +166,16 @@ ARTICLE: "io" "Input and output"
{ $heading "Encodings" }
{ $subsection "encodings-introduction" }
{ $subsection "io.encodings" }
-"Wrapper streams:"
+{ $heading "Wrapper streams:" }
{ $subsection "io.streams.duplex" }
{ $subsection "io.streams.plain" }
{ $subsection "io.streams.string" }
{ $subsection "io.streams.byte-array" }
-"Utilities:"
+{ $heading "Utilities:" }
{ $subsection "stream-binary" }
{ $subsection "styles" }
{ $subsection "checksums" }
-"Implementation:"
+{ $heading "Implementation:" }
{ $subsection "io.streams.c" }
{ $subsection "io.ports" }
{ $see-also "destructors" } ;
From b45c03877b6bf8ea076ce6a008019810231df04e Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Wed, 12 Nov 2008 12:40:09 -0600
Subject: [PATCH 038/157] don't generate 4x the number of random bytes we
actually need. map concat is slower than push-all
---
basis/random/random.factor | 18 +++++++++++++-----
1 file changed, 13 insertions(+), 5 deletions(-)
diff --git a/basis/random/random.factor b/basis/random/random.factor
index a0b62cf7de..0a21d003fa 100755
--- a/basis/random/random.factor
+++ b/basis/random/random.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel math namespaces sequences
io.backend io.binary combinators system vocabs.loader
-summary math.bitwise ;
+summary math.bitwise byte-vectors fry byte-arrays ;
IN: random
SYMBOL: system-random-generator
@@ -13,8 +13,17 @@ GENERIC: seed-random ( tuple seed -- )
GENERIC: random-32* ( tuple -- r )
GENERIC: random-bytes* ( n tuple -- byte-array )
+<PRIVATE
+
+: adjust-random ( n m -- n' )
+ 3 mask 0 = [ 1+ ] unless ; inline
+
+PRIVATE>
+
M: object random-bytes* ( n tuple -- byte-array )
- [ random-32* ] curry replicate [ 4 >le ] map concat ;
+ [ [ 4 /i ] keep adjust-random ] dip
+ over 4 * <byte-vector>
+ [ '[ _ random-32* 4 >le _ push-all ] times ] keep ;
M: object random-32* ( tuple -- r ) 4 random-bytes* le> ;
@@ -29,9 +38,8 @@ M: f random-32* ( obj -- * ) no-random-number-generator ;
: random-bytes ( n -- byte-array )
[
- dup 3 mask zero? [ 1+ ] unless
- random-generator get random-bytes*
- ] keep head ;
+ dup adjust-random random-generator get random-bytes*
+ ] keep head >byte-array ;
<PRIVATE
From a8f1680bcdaa0029a6cc8f532835d32fab8375d7 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Wed, 12 Nov 2008 13:28:17 -0600
Subject: [PATCH 039/157] slightly faster
---
basis/random/random.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/random/random.factor b/basis/random/random.factor
index 0a21d003fa..242a9b8f31 100755
--- a/basis/random/random.factor
+++ b/basis/random/random.factor
@@ -16,7 +16,7 @@ GENERIC: random-bytes* ( n tuple -- byte-array )
<PRIVATE
: adjust-random ( n m -- n' )
- 3 mask 0 = [ 1+ ] unless ; inline
+ 3 mask zero? [ 1+ ] unless ; inline
PRIVATE>
@@ -39,7 +39,7 @@ M: f random-32* ( obj -- * ) no-random-number-generator ;
: random-bytes ( n -- byte-array )
[
dup adjust-random random-generator get random-bytes*
- ] keep head >byte-array ;
+ ] keep head-slice >byte-array ;
<PRIVATE
From 8f6f666a2a872f95d7bcc61585eca8ad0760a2cd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 12 Nov 2008 14:40:01 -0600
Subject: [PATCH 040/157] Neither here nor there
---
basis/help/handbook/handbook.factor | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor
index 0ceedfecb9..d1d9ca049a 100644
--- a/basis/help/handbook/handbook.factor
+++ b/basis/help/handbook/handbook.factor
@@ -166,16 +166,16 @@ ARTICLE: "io" "Input and output"
{ $heading "Encodings" }
{ $subsection "encodings-introduction" }
{ $subsection "io.encodings" }
-{ $heading "Wrapper streams:" }
+{ $heading "Wrapper streams" }
{ $subsection "io.streams.duplex" }
{ $subsection "io.streams.plain" }
{ $subsection "io.streams.string" }
{ $subsection "io.streams.byte-array" }
-{ $heading "Utilities:" }
+{ $heading "Utilities" }
{ $subsection "stream-binary" }
{ $subsection "styles" }
{ $subsection "checksums" }
-{ $heading "Implementation:" }
+{ $heading "Implementation" }
{ $subsection "io.streams.c" }
{ $subsection "io.ports" }
{ $see-also "destructors" } ;
From 4a1bcacfd4ebb74af668e4c32eb51115f13e065a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 12 Nov 2008 19:08:40 -0600
Subject: [PATCH 041/157] Refactoring recursive-state alist; now its a mapping
from words to local state triples, reduces searching by a bit
---
basis/compiler/tree/builder/builder.factor | 11 ++--
basis/stack-checker/backend/backend.factor | 10 ++--
basis/stack-checker/errors/errors.factor | 6 +-
basis/stack-checker/inlining/inlining.factor | 29 +++++-----
.../known-words/known-words.factor | 2 +-
basis/stack-checker/state/state.factor | 58 +++++++++++++------
.../transforms/transforms.factor | 2 +-
7 files changed, 71 insertions(+), 47 deletions(-)
diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor
index 19d80ec14f..65e9ccdff6 100644
--- a/basis/compiler/tree/builder/builder.factor
+++ b/basis/compiler/tree/builder/builder.factor
@@ -12,12 +12,13 @@ IN: compiler.tree.builder
: build-tree ( quot -- nodes )
#! Not safe to call from inference transforms.
- [ f infer-quot ] with-tree-builder nip ;
+ [ f initial-recursive-state infer-quot ] with-tree-builder nip ;
: build-tree-with ( in-stack quot -- nodes out-stack )
#! Not safe to call from inference transforms.
[
- [ >vector meta-d set ] [ f infer-quot ] bi*
+ [ >vector meta-d set ]
+ [ f initial-recursive-state infer-quot ] bi*
] with-tree-builder nip
unclip-last in-d>> ;
@@ -32,10 +33,10 @@ IN: compiler.tree.builder
dup
[ "inline" word-prop ]
[ "recursive" word-prop ] bi and [
- 1quotation f infer-quot
+ 1quotation f initial-recursive-state infer-quot
] [
- [ specialized-def ]
- [ dup 2array 1array ] bi infer-quot
+ [ specialized-def ] [ initial-recursive-state ] bi
+ infer-quot
] if ;
: check-cannot-infer ( word -- )
diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor
index aadd1adbd4..250ee2cb7a 100644
--- a/basis/stack-checker/backend/backend.factor
+++ b/basis/stack-checker/backend/backend.factor
@@ -82,9 +82,6 @@ M: object apply-object push-literal ;
infer-quot-here
] dip recursive-state set ;
-: infer-quot-recursive ( quot word label -- )
- 2array recursive-state get swap prefix infer-quot ;
-
: time-bomb ( error -- )
'[ _ throw ] infer-quot-here ;
@@ -97,7 +94,7 @@ M: object apply-object push-literal ;
] [
dup value>> callable? [
[ value>> ]
- [ [ recursion>> ] keep f 2array prefix ]
+ [ [ recursion>> ] keep add-local-quotation ]
bi infer-quot
] [
drop bad-call
@@ -126,6 +123,9 @@ M: object apply-object push-literal ;
terminated?>> [ terminate ] when
] 2bi ; inline
+: infer-word-def ( word -- )
+ [ def>> ] [ add-recursive-state ] bi infer-quot ;
+
: check->r ( -- )
meta-r get empty? terminated? get or
[ \ too-many->r inference-error ] unless ;
@@ -174,7 +174,7 @@ M: object apply-object push-literal ;
stack-visitor off
dependencies off
generic-dependencies off
- [ [ def>> ] [ ] [ ] tri infer-quot-recursive end-infer ]
+ [ infer-word-def end-infer ]
[ finish-word current-effect ]
bi
] with-scope
diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor
index bab6c17c85..b728d1a7e9 100644
--- a/basis/stack-checker/errors/errors.factor
+++ b/basis/stack-checker/errors/errors.factor
@@ -2,11 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel generic sequences prettyprint io words arrays
summary effects debugger assocs accessors namespaces
-compiler.errors ;
+compiler.errors stack-checker.state ;
IN: stack-checker.errors
-SYMBOL: recursive-state
-
TUPLE: inference-error error type rstate ;
M: inference-error compiler-error-type type>> ;
@@ -35,6 +33,8 @@ TUPLE: literal-expected ;
M: literal-expected summary
drop "Literal value expected" ;
+M: object (literal) \ literal-expected inference-warning ;
+
TUPLE: unbalanced-branches-error branches quots ;
: unbalanced-branches-error ( branches quots -- * )
diff --git a/basis/stack-checker/inlining/inlining.factor b/basis/stack-checker/inlining/inlining.factor
index 7847fdfdcf..695eb4f0d3 100644
--- a/basis/stack-checker/inlining/inlining.factor
+++ b/basis/stack-checker/inlining/inlining.factor
@@ -14,8 +14,8 @@ IN: stack-checker.inlining
! Code to handle inline words. Much of the complexity stems from
! having to handle recursive inline words.
-: (inline-word) ( word label -- )
- [ [ def>> ] keep ] dip infer-quot-recursive ;
+: infer-inline-word-def ( word label -- )
+ [ drop def>> ] [ add-local-recursive-state ] 2bi infer-quot ;
TUPLE: inline-recursive < identity-tuple
id
@@ -88,7 +88,7 @@ SYMBOL: enter-out
nest-visitor
dup <inline-recursive>
- [ dup emit-enter-recursive (inline-word) ]
+ [ dup emit-enter-recursive infer-inline-word-def ]
[ end-recursive-word ]
[ nip ]
2tri
@@ -133,20 +133,23 @@ SYMBOL: enter-out
object <repetition> '[ _ prepend ] bi@
<effect> ;
-: call-recursive-inline-word ( word -- )
- dup "recursive" word-prop [
- [ required-stack-effect adjust-stack-effect ] [ ] [ recursive-label ] tri
- [ 2nip check-call ] [ nip '[ _ #call-recursive, ] consume/produce ] 3bi
- ] [ undeclared-recursion-error inference-error ] if ;
+: call-recursive-inline-word ( word label -- )
+ over "recursive" word-prop [
+ [ required-stack-effect adjust-stack-effect ] dip
+ [ check-call ] [ '[ _ #call-recursive, ] consume/produce ] bi
+ ] [ drop undeclared-recursion-error inference-error ] if ;
: inline-word ( word -- )
[ inlined-dependency depends-on ]
[
- {
- { [ dup inline-recursive-label ] [ call-recursive-inline-word ] }
- { [ dup "recursive" word-prop ] [ inline-recursive-word ] }
- [ dup (inline-word) ]
- } cond
+ dup inline-recursive-label [
+ call-recursive-inline-word
+ ] [
+ dup "recursive" word-prop
+ [ inline-recursive-word ]
+ [ dup infer-inline-word-def ]
+ if
+ ] if*
] bi ;
M: word apply-object
diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index 257181f6ad..ecc9f95f54 100644
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -195,7 +195,7 @@ do-primitive alien-invoke alien-indirect alien-callback
{ [ dup local? ] [ infer-local-reader ] }
{ [ dup local-reader? ] [ infer-local-reader ] }
{ [ dup local-writer? ] [ infer-local-writer ] }
- { [ dup recursive-label ] [ call-recursive-word ] }
+ { [ dup recursive-word? ] [ call-recursive-word ] }
[ dup infer-word apply-word/effect ]
} cond ;
diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor
index 11dc6f9ef8..177731f985 100644
--- a/basis/stack-checker/state/state.factor
+++ b/basis/stack-checker/state/state.factor
@@ -1,10 +1,38 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs namespaces sequences kernel definitions math
-effects accessors words fry classes.algebra stack-checker.errors
+USING: assocs arrays namespaces sequences kernel definitions
+math effects accessors words fry classes.algebra
compiler.units ;
IN: stack-checker.state
+! Recursive state
+SYMBOL: recursive-state
+
+: initial-recursive-state ( word -- state )
+ { } { } 3array 1array ; inline
+
+f initial-recursive-state recursive-state set-global
+
+: add-recursive-state ( word -- rstate )
+ [ recursive-state get ] dip { } { } 3array prefix ;
+
+: add-local-quotation ( recursive-state quot -- rstate )
+ [ unclip first3 swap ] dip prefix swap 3array prefix ;
+
+: add-local-recursive-state ( word label -- rstate )
+ [ recursive-state get ] 2dip
+ [ unclip first3 ] 2dip 2array prefix 3array prefix ;
+
+: recursive-word? ( word -- ? )
+ recursive-state get key? ;
+
+: inline-recursive-label ( word -- label/f )
+ recursive-state get first third at ;
+
+: recursive-quotation? ( quot -- ? )
+ recursive-state get first second [ eq? ] with contains? ;
+
+! Values
: <value> ( -- value ) \ <value> counter ;
SYMBOL: known-values
@@ -29,9 +57,12 @@ TUPLE: literal < identity-tuple value recursion ;
: <literal> ( obj -- value )
recursive-state get \ literal boa ;
+GENERIC: (literal) ( value -- literal )
+
+M: literal (literal) ;
+
: literal ( value -- literal )
- known dup literal?
- [ \ literal-expected inference-warning ] unless ;
+ known (literal) ;
! Result of curry
TUPLE: curried obj quot ;
@@ -71,20 +102,6 @@ SYMBOL: meta-r
: init-known-values ( -- )
H{ } clone known-values set ;
-: recursive-label ( word -- label/f )
- recursive-state get at ;
-
-: local-recursive-state ( -- assoc )
- recursive-state get dup
- [ first dup word? [ inline? ] when not ] find drop
- [ head-slice ] when* ;
-
-: inline-recursive-label ( word -- label/f )
- local-recursive-state at ;
-
-: recursive-quotation? ( quot -- ? )
- local-recursive-state [ first eq? ] with contains? ;
-
! Words that the current quotation depends on
SYMBOL: dependencies
@@ -98,9 +115,12 @@ SYMBOL: dependencies
! Generic words that the current quotation depends on
SYMBOL: generic-dependencies
+: ?class-or ( class/f class -- class' )
+ swap [ class-or ] when* ;
+
: depends-on-generic ( generic class -- )
generic-dependencies get dup
- [ swap '[ null or _ class-or ] change-at ] [ 3drop ] if ;
+ [ swap '[ _ ?class-or ] change-at ] [ 3drop ] if ;
! Words we've inferred the stack effect of, for rollback
SYMBOL: recorded
diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor
index abc3ae1950..c71337b021 100644
--- a/basis/stack-checker/transforms/transforms.factor
+++ b/basis/stack-checker/transforms/transforms.factor
@@ -9,7 +9,7 @@ stack-checker.errors ;
IN: stack-checker.transforms
: give-up-transform ( word -- )
- dup recursive-label
+ dup recursive-word?
[ call-recursive-word ]
[ dup infer-word apply-word/effect ]
if ;
From db2f744f90eea9f9b115cb31a4d1790645f2d4ea Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Wed, 12 Nov 2008 22:10:34 -0600
Subject: [PATCH 042/157] redo random-bytes* with a better algorithm
---
basis/random/random.factor | 22 ++++++++--------------
1 file changed, 8 insertions(+), 14 deletions(-)
diff --git a/basis/random/random.factor b/basis/random/random.factor
index 242a9b8f31..5c93606ab5 100755
--- a/basis/random/random.factor
+++ b/basis/random/random.factor
@@ -13,17 +13,13 @@ GENERIC: seed-random ( tuple seed -- )
GENERIC: random-32* ( tuple -- r )
GENERIC: random-bytes* ( n tuple -- byte-array )
-<PRIVATE
-
-: adjust-random ( n m -- n' )
- 3 mask zero? [ 1+ ] unless ; inline
-
-PRIVATE>
-
M: object random-bytes* ( n tuple -- byte-array )
- [ [ 4 /i ] keep adjust-random ] dip
- over 4 * <byte-vector>
- [ '[ _ random-32* 4 >le _ push-all ] times ] keep ;
+ [ [ <byte-vector> ] keep 4 /mod ] dip tuck
+ [ pick '[ _ random-32* 4 >le _ push-all ] times ]
+ [
+ over zero?
+ [ 2drop ] [ random-32* 4 >le swap head over push-all ] if
+ ] 2bi* ;
M: object random-32* ( tuple -- r ) 4 random-bytes* le> ;
@@ -37,15 +33,13 @@ M: f random-bytes* ( n obj -- * ) no-random-number-generator ;
M: f random-32* ( obj -- * ) no-random-number-generator ;
: random-bytes ( n -- byte-array )
- [
- dup adjust-random random-generator get random-bytes*
- ] keep head-slice >byte-array ;
+ random-generator get random-bytes* ;
<PRIVATE
: random-integer ( n -- n' )
dup log2 7 + 8 /i 1+
- [ random-bytes byte-array>bignum ]
+ [ random-bytes >byte-array byte-array>bignum ]
[ 3 shift 2^ ] bi / * >integer ;
PRIVATE>
From 5bae69426db5b2019fd2bdec55526f596d1d18a0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 13 Nov 2008 00:07:45 -0600
Subject: [PATCH 043/157] Stack checker cleanup and optimization -
stack-checker.state vocabulary split up into
stack-checker.{state,values,recursive-state} - code that modifies and
searches recursive state factored out into stack-checker.recursive-state -
recursive state is now a set of three binary hash trees instead of an alist,
and no longer contains unnecessary data - binary hash trees are in
stack-checker.recursive-state.tree: unbalanced, persistent - ~8 second
speedup on bootstrap, ~20 second speedup in "peg.javascript" require
---
basis/compiler/tree/builder/builder.factor | 10 ++-
.../allocations/allocations.factor | 2 +-
basis/stack-checker/backend/backend.factor | 3 +-
basis/stack-checker/branches/branches.factor | 2 +-
basis/stack-checker/errors/errors.factor | 12 ++--
basis/stack-checker/inlining/inlining.factor | 8 ++-
.../known-words/known-words.factor | 9 +--
.../recursive-state/recursive-state.factor | 43 +++++++++++
.../recursive-state/tree/tree.factor | 31 ++++++++
basis/stack-checker/state/state.factor | 72 -------------------
.../transforms/transforms.factor | 3 +-
basis/stack-checker/values/values.factor | 52 ++++++++++++++
12 files changed, 154 insertions(+), 93 deletions(-)
create mode 100644 basis/stack-checker/recursive-state/recursive-state.factor
create mode 100644 basis/stack-checker/recursive-state/tree/tree.factor
create mode 100644 basis/stack-checker/values/values.factor
diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor
index 65e9ccdff6..c2ec6552cd 100644
--- a/basis/compiler/tree/builder/builder.factor
+++ b/basis/compiler/tree/builder/builder.factor
@@ -1,9 +1,13 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors quotations kernel sequences namespaces
-assocs words arrays vectors hints combinators stack-checker
-stack-checker.state stack-checker.visitor stack-checker.errors
-stack-checker.backend compiler.tree ;
+assocs words arrays vectors hints combinators compiler.tree
+stack-checker
+stack-checker.state
+stack-checker.errors
+stack-checker.visitor
+stack-checker.backend
+stack-checker.recursive-state ;
IN: compiler.tree.builder
: with-tree-builder ( quot -- nodes )
diff --git a/basis/compiler/tree/escape-analysis/allocations/allocations.factor b/basis/compiler/tree/escape-analysis/allocations/allocations.factor
index 4c197d7fc0..5d34eaad15 100644
--- a/basis/compiler/tree/escape-analysis/allocations/allocations.factor
+++ b/basis/compiler/tree/escape-analysis/allocations/allocations.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs namespaces sequences kernel math
-combinators sets disjoint-sets fry stack-checker.state ;
+combinators sets disjoint-sets fry stack-checker.values ;
IN: compiler.tree.escape-analysis.allocations
! A map from values to one of the following:
diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor
index 250ee2cb7a..94e59950f7 100644
--- a/basis/stack-checker/backend/backend.factor
+++ b/basis/stack-checker/backend/backend.factor
@@ -5,7 +5,8 @@ namespaces parser prettyprint sequences strings vectors words
quotations effects classes continuations debugger assocs
combinators compiler.errors accessors math.order definitions
sets generic.standard.engines.tuple stack-checker.state
-stack-checker.visitor stack-checker.errors ;
+stack-checker.visitor stack-checker.errors
+stack-checker.values stack-checker.recursive-state ;
IN: stack-checker.backend
: push-d ( obj -- ) meta-d get push ;
diff --git a/basis/stack-checker/branches/branches.factor b/basis/stack-checker/branches/branches.factor
index d1417d035c..7b461d0028 100644
--- a/basis/stack-checker/branches/branches.factor
+++ b/basis/stack-checker/branches/branches.factor
@@ -3,7 +3,7 @@
USING: fry vectors sequences assocs math accessors kernel
combinators quotations namespaces stack-checker.state
stack-checker.backend stack-checker.errors stack-checker.visitor
-;
+stack-checker.values stack-checker.recursive-state ;
IN: stack-checker.branches
: balanced? ( pairs -- ? )
diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor
index b728d1a7e9..efdc7e23b2 100644
--- a/basis/stack-checker/errors/errors.factor
+++ b/basis/stack-checker/errors/errors.factor
@@ -2,10 +2,11 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel generic sequences prettyprint io words arrays
summary effects debugger assocs accessors namespaces
-compiler.errors stack-checker.state ;
+compiler.errors stack-checker.values
+stack-checker.recursive-state ;
IN: stack-checker.errors
-TUPLE: inference-error error type rstate ;
+TUPLE: inference-error error type word ;
M: inference-error compiler-error-type type>> ;
@@ -13,7 +14,7 @@ M: inference-error error-help error>> error-help ;
: (inference-error) ( ... class type -- * )
>r boa r>
- recursive-state get
+ recursive-state get word>>
\ inference-error boa throw ; inline
: inference-error ( ... class -- * )
@@ -23,10 +24,7 @@ M: inference-error error-help error>> error-help ;
+warning+ (inference-error) ; inline
M: inference-error error.
- [
- rstate>>
- [ "Nesting:" print stack. ] unless-empty
- ] [ error>> error. ] bi ;
+ [ "In word: " write word>> . ] [ error>> error. ] bi ;
TUPLE: literal-expected ;
diff --git a/basis/stack-checker/inlining/inlining.factor b/basis/stack-checker/inlining/inlining.factor
index 695eb4f0d3..b6a988652b 100644
--- a/basis/stack-checker/inlining/inlining.factor
+++ b/basis/stack-checker/inlining/inlining.factor
@@ -4,18 +4,20 @@ USING: fry namespaces assocs kernel sequences words accessors
definitions math math.order effects classes arrays combinators
vectors arrays
stack-checker.state
+stack-checker.errors
+stack-checker.values
stack-checker.visitor
stack-checker.backend
stack-checker.branches
-stack-checker.errors
-stack-checker.known-words ;
+stack-checker.known-words
+stack-checker.recursive-state ;
IN: stack-checker.inlining
! Code to handle inline words. Much of the complexity stems from
! having to handle recursive inline words.
: infer-inline-word-def ( word label -- )
- [ drop def>> ] [ add-local-recursive-state ] 2bi infer-quot ;
+ [ drop def>> ] [ add-inline-word ] 2bi infer-quot ;
TUPLE: inline-recursive < identity-tuple
id
diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index ecc9f95f54..4aea0f2d28 100644
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -11,14 +11,15 @@ strings.private system threads.private classes.tuple
classes.tuple.private vectors vectors.private words definitions
words.private assocs summary compiler.units system.private
combinators locals locals.backend locals.private words.private
-quotations.private
+quotations.private stack-checker.values
+stack-checker.alien
stack-checker.state
+stack-checker.errors
+stack-checker.visitor
stack-checker.backend
stack-checker.branches
-stack-checker.errors
stack-checker.transforms
-stack-checker.visitor
-stack-checker.alien ;
+stack-checker.recursive-state ;
IN: stack-checker.known-words
: infer-primitive ( word -- )
diff --git a/basis/stack-checker/recursive-state/recursive-state.factor b/basis/stack-checker/recursive-state/recursive-state.factor
new file mode 100644
index 0000000000..41d7331230
--- /dev/null
+++ b/basis/stack-checker/recursive-state/recursive-state.factor
@@ -0,0 +1,43 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays sequences kernel sequences assocs
+namespaces stack-checker.recursive-state.tree ;
+IN: stack-checker.recursive-state
+
+TUPLE: recursive-state words word quotations inline-words ;
+
+C: <recursive-state> recursive-state
+
+: prepare-recursive-state ( word rstate -- rstate )
+ swap >>word
+ f >>quotations
+ f >>inline-words ; inline
+
+: initial-recursive-state ( word -- state )
+ recursive-state new
+ f >>words
+ prepare-recursive-state ; inline
+
+f initial-recursive-state recursive-state set-global
+
+: add-recursive-state ( word -- rstate )
+ recursive-state get clone
+ [ word>> dup ] keep [ store ] change-words
+ prepare-recursive-state ;
+
+: add-local-quotation ( recursive-state quot -- rstate )
+ swap clone [ dupd store ] change-quotations ;
+
+: add-inline-word ( word label -- rstate )
+ swap recursive-state get clone
+ [ store ] change-inline-words ;
+
+: recursive-word? ( word -- ? )
+ recursive-state get 2dup word>> eq?
+ [ 2drop t ] [ words>> lookup ] if ;
+
+: inline-recursive-label ( word -- label/f )
+ recursive-state get inline-words>> lookup ;
+
+: recursive-quotation? ( quot -- ? )
+ recursive-state get quotations>> lookup ;
diff --git a/basis/stack-checker/recursive-state/tree/tree.factor b/basis/stack-checker/recursive-state/tree/tree.factor
new file mode 100644
index 0000000000..dd392af7c9
--- /dev/null
+++ b/basis/stack-checker/recursive-state/tree/tree.factor
@@ -0,0 +1,31 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences math math.order ;
+IN: stack-checker.recursive-state.tree
+
+! Persistent unbalanced hash tree using eq? comparison.
+! We use this to speed up stack-checker.recursive-state.
+! Perhaps this should go somewhere else
+
+TUPLE: node value key hashcode left right ;
+
+GENERIC: lookup ( key node -- value/f )
+
+M: f lookup nip ;
+
+: decide ( key node -- key node ? )
+ over hashcode over hashcode>> <= ; inline
+
+M: node lookup
+ 2dup key>> eq?
+ [ nip value>> ]
+ [ decide [ left>> ] [ right>> ] if lookup ] if ;
+
+GENERIC: store ( value key node -- node' )
+
+M: f store drop dup hashcode f f node boa ;
+
+M: node store
+ clone decide
+ [ [ store ] change-left ]
+ [ [ store ] change-right ] if ;
diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor
index 177731f985..2706ec60ef 100644
--- a/basis/stack-checker/state/state.factor
+++ b/basis/stack-checker/state/state.factor
@@ -5,75 +5,6 @@ math effects accessors words fry classes.algebra
compiler.units ;
IN: stack-checker.state
-! Recursive state
-SYMBOL: recursive-state
-
-: initial-recursive-state ( word -- state )
- { } { } 3array 1array ; inline
-
-f initial-recursive-state recursive-state set-global
-
-: add-recursive-state ( word -- rstate )
- [ recursive-state get ] dip { } { } 3array prefix ;
-
-: add-local-quotation ( recursive-state quot -- rstate )
- [ unclip first3 swap ] dip prefix swap 3array prefix ;
-
-: add-local-recursive-state ( word label -- rstate )
- [ recursive-state get ] 2dip
- [ unclip first3 ] 2dip 2array prefix 3array prefix ;
-
-: recursive-word? ( word -- ? )
- recursive-state get key? ;
-
-: inline-recursive-label ( word -- label/f )
- recursive-state get first third at ;
-
-: recursive-quotation? ( quot -- ? )
- recursive-state get first second [ eq? ] with contains? ;
-
-! Values
-: <value> ( -- value ) \ <value> counter ;
-
-SYMBOL: known-values
-
-: known ( value -- known ) known-values get at ;
-
-: set-known ( known value -- )
- over [ known-values get set-at ] [ 2drop ] if ;
-
-: make-known ( known -- value )
- <value> [ set-known ] keep ;
-
-: copy-value ( value -- value' )
- known make-known ;
-
-: copy-values ( values -- values' )
- [ copy-value ] map ;
-
-! Literal value
-TUPLE: literal < identity-tuple value recursion ;
-
-: <literal> ( obj -- value )
- recursive-state get \ literal boa ;
-
-GENERIC: (literal) ( value -- literal )
-
-M: literal (literal) ;
-
-: literal ( value -- literal )
- known (literal) ;
-
-! Result of curry
-TUPLE: curried obj quot ;
-
-C: <curried> curried
-
-! Result of compose
-TUPLE: composed quot1 quot2 ;
-
-C: <composed> composed
-
! Did the current control-flow path throw an error?
SYMBOL: terminated?
@@ -99,9 +30,6 @@ SYMBOL: meta-r
V{ } clone meta-r set
0 d-in set ;
-: init-known-values ( -- )
- H{ } clone known-values set ;
-
! Words that the current quotation depends on
SYMBOL: dependencies
diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor
index c71337b021..e4f8c50eeb 100644
--- a/basis/stack-checker/transforms/transforms.factor
+++ b/basis/stack-checker/transforms/transforms.factor
@@ -5,7 +5,8 @@ namespaces make quotations assocs combinators classes.tuple
classes.tuple.private effects summary hashtables classes generic
sets definitions generic.standard slots.private continuations
stack-checker.backend stack-checker.state stack-checker.visitor
-stack-checker.errors ;
+stack-checker.errors stack-checker.values
+stack-checker.recursive-state ;
IN: stack-checker.transforms
: give-up-transform ( word -- )
diff --git a/basis/stack-checker/values/values.factor b/basis/stack-checker/values/values.factor
new file mode 100644
index 0000000000..97aa774e55
--- /dev/null
+++ b/basis/stack-checker/values/values.factor
@@ -0,0 +1,52 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors namespaces kernel assocs sequences
+stack-checker.recursive-state ;
+IN: stack-checker.values
+
+! Values
+: <value> ( -- value ) \ <value> counter ;
+
+SYMBOL: known-values
+
+: init-known-values ( -- )
+ H{ } clone known-values set ;
+
+: known ( value -- known ) known-values get at ;
+
+: set-known ( known value -- )
+ over [ known-values get set-at ] [ 2drop ] if ;
+
+: make-known ( known -- value )
+ <value> [ set-known ] keep ;
+
+: copy-value ( value -- value' )
+ known make-known ;
+
+: copy-values ( values -- values' )
+ [ copy-value ] map ;
+
+! Literal value
+TUPLE: literal < identity-tuple value recursion hashcode ;
+
+M: literal hashcode* nip hashcode>> ;
+
+: <literal> ( obj -- value )
+ recursive-state get over hashcode \ literal boa ;
+
+GENERIC: (literal) ( value -- literal )
+
+M: literal (literal) ;
+
+: literal ( value -- literal )
+ known (literal) ;
+
+! Result of curry
+TUPLE: curried obj quot ;
+
+C: <curried> curried
+
+! Result of compose
+TUPLE: composed quot1 quot2 ;
+
+C: <composed> composed
From 3bb778eab4771d549e0fa7b06d2c3fd8443b850e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 13 Nov 2008 00:09:47 -0600
Subject: [PATCH 044/157] Remove unnecessary stack-checker.transforms
dependency from macros
---
basis/macros/expander/expander.factor | 2 +-
basis/macros/macros.factor | 15 ++++++---------
2 files changed, 7 insertions(+), 10 deletions(-)
diff --git a/basis/macros/expander/expander.factor b/basis/macros/expander/expander.factor
index c2fceffae6..3666fa2423 100644
--- a/basis/macros/expander/expander.factor
+++ b/basis/macros/expander/expander.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private namespaces make
quotations accessors words continuations vectors effects math
-generalizations stack-checker.transforms fry ;
+generalizations fry ;
IN: macros.expander
GENERIC: expand-macros ( quot -- quot' )
diff --git a/basis/macros/macros.factor b/basis/macros/macros.factor
index 0a6621f044..794d523d00 100644
--- a/basis/macros/macros.factor
+++ b/basis/macros/macros.factor
@@ -1,21 +1,18 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: parser kernel sequences words effects
-stack-checker.transforms combinators assocs definitions
-quotations namespaces memoize accessors ;
+USING: parser kernel sequences words effects combinators assocs
+definitions quotations namespaces memoize accessors ;
IN: macros
: real-macro-effect ( word -- effect' )
"declared-effect" word-prop in>> 1 <effect> ;
: define-macro ( word definition -- )
- over "declared-effect" word-prop in>> length >r
- 2dup "macro" set-word-prop
- 2dup over real-macro-effect memoize-quot [ call ] append define
- r> define-transform ;
+ [ "macro" set-word-prop ]
+ [ over real-macro-effect memoize-quot [ call ] append define ]
+ 2bi ;
-: MACRO:
- (:) define-macro ; parsing
+: MACRO: (:) define-macro ; parsing
PREDICATE: macro < word "macro" word-prop >boolean ;
From a81e737e025e9c9e2e3f45ebe108782612149789 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 13 Nov 2008 00:10:37 -0600
Subject: [PATCH 045/157] Add passociate word: like associate but for
persistent hashtables
---
basis/persistent/hashtables/hashtables.factor | 3 +++
1 file changed, 3 insertions(+)
diff --git a/basis/persistent/hashtables/hashtables.factor b/basis/persistent/hashtables/hashtables.factor
index a867dbb2e3..e50fd52c10 100644
--- a/basis/persistent/hashtables/hashtables.factor
+++ b/basis/persistent/hashtables/hashtables.factor
@@ -53,3 +53,6 @@ M: persistent-hash clone ;
M: persistent-hash pprint-delims drop \ PH{ \ } ;
M: persistent-hash >pprint-sequence >alist ;
M: persistent-hash pprint* pprint-object ;
+
+: passociate ( value key -- phash )
+ T{ persistent-hash } new-at ; inline
From 3f4eb5a09a4841fd4542b68b6393529d4d99cb8f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 13 Nov 2008 00:10:55 -0600
Subject: [PATCH 046/157] Add changed-nth combinator: like change-nth but for
persistent sequences
---
basis/persistent/sequences/sequences.factor | 3 +++
1 file changed, 3 insertions(+)
diff --git a/basis/persistent/sequences/sequences.factor b/basis/persistent/sequences/sequences.factor
index 961e8bfce7..5503e369b4 100644
--- a/basis/persistent/sequences/sequences.factor
+++ b/basis/persistent/sequences/sequences.factor
@@ -14,3 +14,6 @@ M: sequence ppop 1 head* ;
GENERIC: new-nth ( val i seq -- seq' )
M: sequence new-nth clone [ set-nth ] keep ;
+
+: changed-nth ( i seq quot -- seq' )
+ [ [ nth ] dip call ] [ drop new-nth ] 3bi ; inline
From 3723b2e64046c704c73193d66a3ed078bd9808cb Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 13 Nov 2008 00:12:14 -0600
Subject: [PATCH 047/157] vlists: immutable sequences with mostly-O(1) push and
pop, O(n) behavior when sharing: optimized for the unshared case. also
contains valists, which are assocs built on vlists with O(n) search starting
from the end, and mostly-O(1) insertion that shadows prior entries. Behaves
similar to Lisp/Scheme alists
---
basis/vlists/vlists-tests.factor | 41 ++++++++++++++
basis/vlists/vlists.factor | 93 ++++++++++++++++++++++++++++++++
2 files changed, 134 insertions(+)
create mode 100644 basis/vlists/vlists-tests.factor
create mode 100644 basis/vlists/vlists.factor
diff --git a/basis/vlists/vlists-tests.factor b/basis/vlists/vlists-tests.factor
new file mode 100644
index 0000000000..3546051364
--- /dev/null
+++ b/basis/vlists/vlists-tests.factor
@@ -0,0 +1,41 @@
+USING: vlists kernel persistent.sequences arrays tools.test
+namespaces accessors sequences assocs ;
+IN: vlists.tests
+
+[ { "hi" "there" } ]
+[ VL{ } "hi" swap ppush "there" swap ppush >array ] unit-test
+
+[ VL{ "hi" "there" "foo" } VL{ "hi" "there" "bar" } t ]
+[
+ VL{ } "hi" swap ppush "there" swap ppush "v" set
+ "foo" "v" get ppush
+ "bar" "v" get ppush
+ dup "baz" over ppush [ vector>> ] bi@ eq?
+] unit-test
+
+[ "foo" VL{ "hi" "there" } t ]
+[
+ VL{ "hi" "there" "foo" } dup "v" set
+ [ peek ] [ ppop ] bi
+ dup "v" get [ vector>> ] bi@ eq?
+] unit-test
+
+[ VL{ } 3 over push ] must-fail
+
+[ 4 VL{ "hi" } set-first ] must-fail
+
+[ 5 t ] [
+ "rice" VA{ { "rice" 5 } { "beans" 10 } } at*
+] unit-test
+
+[ 6 t ] [
+ "rice" VA{ { "rice" 5 } { "beans" 10 } { "rice" 6 } } at*
+] unit-test
+
+[ 3 ] [
+ VA{ { "rice" 5 } { "beans" 10 } { "rice" 6 } } assoc-size
+] unit-test
+
+[ f f ] [
+ "meat" VA{ { "rice" 5 } { "beans" 10 } { "rice" 6 } } at*
+] unit-test
diff --git a/basis/vlists/vlists.factor b/basis/vlists/vlists.factor
new file mode 100644
index 0000000000..e0f7e55554
--- /dev/null
+++ b/basis/vlists/vlists.factor
@@ -0,0 +1,93 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays accessors sequences sequences.private
+persistent.sequences assocs persistent.assocs kernel math
+vectors parser prettyprint.backend ;
+IN: vlists
+
+TUPLE: vlist
+{ length array-capacity read-only }
+{ vector vector read-only } ;
+
+: <vlist> ( -- vlist ) 0 V{ } clone vlist boa ; inline
+
+M: vlist length length>> ;
+
+M: vlist nth-unsafe vector>> nth-unsafe ;
+
+<PRIVATE
+
+: >vlist< [ length>> ] [ vector>> ] bi ; inline
+
+: unshare ( len vec -- len vec' )
+ clone [ set-length ] 2keep ; inline
+
+PRIVATE>
+
+M: vlist ppush
+ >vlist<
+ 2dup length = [ unshare ] unless
+ [ [ 1+ swap ] dip push ] keep vlist boa ;
+
+ERROR: empty-vlist-error ;
+
+M: vlist ppop
+ [ empty-vlist-error ]
+ [ [ length>> 1- ] [ vector>> ] bi vlist boa ] if-empty ;
+
+M: vlist clone
+ [ length>> ] [ vector>> >vector ] bi vlist boa ;
+
+M: vlist equal?
+ over vlist? [ sequence= ] [ 2drop f ] if ;
+
+: >vlist ( seq -- vlist )
+ [ length ] [ >vector ] bi vlist boa ; inline
+
+M: vlist like
+ drop dup vlist? [ >vlist ] unless ;
+
+INSTANCE: vlist immutable-sequence
+
+: VL{ \ } [ >vlist ] parse-literal ; parsing
+
+M: vlist pprint-delims drop \ VL{ \ } ;
+M: vlist >pprint-sequence ;
+M: vlist pprint* pprint-object ;
+
+TUPLE: valist { vlist vlist read-only } ;
+
+: <valist> ( -- valist ) <vlist> valist boa ; inline
+
+M: valist assoc-size vlist>> length 2/ ;
+
+: valist-at ( key i array -- value ? )
+ over 0 >= [
+ 3dup nth-unsafe = [
+ [ 1+ ] dip nth-unsafe nip t
+ ] [
+ [ 2 - ] dip valist-at
+ ] if
+ ] [ 3drop f f ] if ; inline recursive
+
+M: valist at*
+ vlist>> >vlist< [ 2 - ] [ underlying>> ] bi* valist-at ;
+
+M: valist new-at
+ vlist>> ppush ppush valist boa ;
+
+M: valist >alist vlist>> ;
+
+: >valist ( assoc -- valist )
+ >alist concat >vlist valist boa ; inline
+
+M: valist assoc-like
+ drop dup valist? [ >valist ] unless ;
+
+INSTANCE: valist assoc
+
+: VA{ \ } [ >valist ] parse-literal ; parsing
+
+M: valist pprint-delims drop \ VA{ \ } ;
+M: valist >pprint-sequence >alist ;
+M: valist pprint* pprint-object ;
From cfa82cb4746078f042c1d190867937d3ce1a0eb7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 13 Nov 2008 03:20:34 -0600
Subject: [PATCH 048/157] New calling convention for VM primitives: instead of
the Factor side passing the stack pointer as the first parameter, and having
the VM save it to stack_chain->top, we instead have the Factor side save it.
Eliminates a lot of crud in the VM
---
basis/bootstrap/image/image.factor | 3 +
basis/cpu/ppc/bootstrap.factor | 7 +-
basis/cpu/x86/32/bootstrap.factor | 11 +++-
basis/cpu/x86/64/bootstrap.factor | 13 +++-
basis/cpu/x86/bootstrap.factor | 6 --
vm/alien.c | 16 ++---
vm/alien.h | 64 +++++++++---------
vm/callstack.c | 17 ++---
vm/callstack.h | 17 +++--
vm/code_gc.c | 2 +-
vm/code_gc.h | 2 +-
vm/code_heap.c | 6 +-
vm/code_heap.h | 8 ++-
vm/data_gc.c | 18 +++---
vm/data_gc.h | 18 +++---
vm/debug.c | 2 +-
vm/debug.h | 2 +-
vm/errors.c | 6 +-
vm/errors.h | 8 +--
vm/image.c | 4 +-
vm/image.h | 4 +-
vm/io.c | 14 ++--
vm/io.h | 20 +++---
vm/math.c | 98 ++++++++++++++--------------
vm/math.h | 100 ++++++++++++++---------------
vm/os-unix.c | 2 +-
vm/os-windows-ce.c | 2 +-
vm/os-windows.c | 2 +-
vm/primitives.h | 41 ------------
vm/profiler.c | 2 +-
vm/profiler.h | 2 +-
vm/quotations.c | 6 +-
vm/quotations.h | 4 +-
vm/run.c | 20 +++---
vm/run.h | 28 ++++----
vm/types.c | 30 ++++-----
vm/types.h | 30 ++++-----
37 files changed, 308 insertions(+), 327 deletions(-)
diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor
index 8b0051148f..c0fafdc0f5 100644
--- a/basis/bootstrap/image/image.factor
+++ b/basis/bootstrap/image/image.factor
@@ -134,6 +134,7 @@ SYMBOL: jit-epilog
SYMBOL: jit-return
SYMBOL: jit-profiling
SYMBOL: jit-declare-word
+SYMBOL: jit-save-stack
! Default definition for undefined words
SYMBOL: undefined-quot
@@ -158,6 +159,7 @@ SYMBOL: undefined-quot
{ jit-profiling 35 }
{ jit-push-immediate 36 }
{ jit-declare-word 42 }
+ { jit-save-stack 43 }
{ undefined-quot 60 }
} at header-size + ;
@@ -459,6 +461,7 @@ M: quotation '
jit-return
jit-profiling
jit-declare-word
+ jit-save-stack
undefined-quot
} [ emit-userenv ] each ;
diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor
index 9bf88185c5..8809311f21 100644
--- a/basis/cpu/ppc/bootstrap.factor
+++ b/basis/cpu/ppc/bootstrap.factor
@@ -57,7 +57,12 @@ big-endian on
[
0 6 LOAD32
- 4 1 MR
+ 7 6 0 LWZ
+ 1 7 0 STW
+] rc-absolute-ppc-2/2 rt-primitive 1 jit-save-stack jit-define
+
+[
+ 0 6 LOAD32
6 MTCTR
BCTR
] rc-absolute-ppc-2/2 rt-primitive 1 jit-primitive jit-define
diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor
index 44f840e66a..ba963ab477 100644
--- a/basis/cpu/x86/32/bootstrap.factor
+++ b/basis/cpu/x86/32/bootstrap.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system
-cpu.x86.assembler layouts vocabs parser ;
+cpu.x86.assembler layouts vocabs parser compiler.constants ;
IN: bootstrap.x86
4 \ cell set
@@ -19,5 +19,14 @@ IN: bootstrap.x86
: fixnum>slot@ ( -- ) arg0 1 SAR ;
: rex-length ( -- n ) 0 ;
+[
+ arg0 0 [] MOV ! load stack_chain
+ arg0 [] stack-reg MOV ! save stack pointer
+] rc-absolute-cell rt-stack-chain 2 jit-save-stack jit-define
+
+[
+ (JMP) drop
+] rc-relative rt-primitive 1 jit-primitive jit-define
+
<< "resource:basis/cpu/x86/bootstrap.factor" parse-file parsed >>
call
diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor
index acac8b55bc..83a72d6dd3 100644
--- a/basis/cpu/x86/64/bootstrap.factor
+++ b/basis/cpu/x86/64/bootstrap.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system
-cpu.x86.assembler layouts vocabs parser ;
+cpu.x86.assembler layouts vocabs parser compiler.constants math ;
IN: bootstrap.x86
8 \ cell set
@@ -16,5 +16,16 @@ IN: bootstrap.x86
: fixnum>slot@ ( -- ) ;
: rex-length ( -- n ) 1 ;
+[
+ arg0 0 MOV ! load stack_chain
+ arg0 arg0 [] MOV
+ arg0 [] stack-reg MOV ! save stack pointer
+] rc-absolute-cell rt-stack-chain 1 rex-length + jit-save-stack jit-define
+
+[
+ arg1 0 MOV ! load XT
+ arg1 JMP ! go
+] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define
+
<< "resource:basis/cpu/x86/bootstrap.factor" parse-file parsed >>
call
diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor
index 6dadbc096c..1ee74a434b 100644
--- a/basis/cpu/x86/bootstrap.factor
+++ b/basis/cpu/x86/bootstrap.factor
@@ -44,12 +44,6 @@ big-endian off
ds-reg [] arg0 MOV ! store literal on datastack
] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define
-[
- arg0 0 MOV ! load XT
- arg1 stack-reg MOV ! pass callstack pointer as arg 2
- arg0 JMP ! go
-] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define
-
[
(JMP) drop
] rc-relative rt-xt 1 jit-word-jump jit-define
diff --git a/vm/alien.c b/vm/alien.c
index 5b4ff3b832..8b7df45e9a 100755
--- a/vm/alien.c
+++ b/vm/alien.c
@@ -82,7 +82,7 @@ void box_alien(void *ptr)
}
/* make an alien pointing at an offset of another alien */
-DEFINE_PRIMITIVE(displaced_alien)
+void primitive_displaced_alien(void)
{
CELL alien = dpop();
CELL displacement = to_cell(dpop());
@@ -107,7 +107,7 @@ DEFINE_PRIMITIVE(displaced_alien)
/* address of an object representing a C pointer. Explicitly throw an error
if the object is a byte array, as a sanity check. */
-DEFINE_PRIMITIVE(alien_address)
+void primitive_alien_address(void)
{
box_unsigned_cell((CELL)pinned_alien_offset(dpop()));
}
@@ -121,11 +121,11 @@ INLINE void *alien_pointer(void)
/* define words to read/write values at an alien address */
#define DEFINE_ALIEN_ACCESSOR(name,type,boxer,to) \
- DEFINE_PRIMITIVE(alien_##name) \
+ void primitive_alien_##name(void) \
{ \
boxer(*(type*)alien_pointer()); \
} \
- DEFINE_PRIMITIVE(set_alien_##name) \
+ void primitive_set_alien_##name(void) \
{ \
type* ptr = alien_pointer(); \
type value = to(dpop()); \
@@ -170,7 +170,7 @@ void box_small_struct(CELL x, CELL y, CELL size)
}
/* open a native library and push a handle */
-DEFINE_PRIMITIVE(dlopen)
+void primitive_dlopen(void)
{
CELL path = tag_object(string_to_native_alien(
untag_string(dpop())));
@@ -183,7 +183,7 @@ DEFINE_PRIMITIVE(dlopen)
}
/* look up a symbol in a native library */
-DEFINE_PRIMITIVE(dlsym)
+void primitive_dlsym(void)
{
CELL dll = dpop();
REGISTER_ROOT(dll);
@@ -205,12 +205,12 @@ DEFINE_PRIMITIVE(dlsym)
}
/* close a native library handle */
-DEFINE_PRIMITIVE(dlclose)
+void primitive_dlclose(void)
{
ffi_dlclose(untag_dll(dpop()));
}
-DEFINE_PRIMITIVE(dll_validp)
+void primitive_dll_validp(void)
{
CELL dll = dpop();
if(dll == F)
diff --git a/vm/alien.h b/vm/alien.h
index babfbc358d..ec1eb08acf 100755
--- a/vm/alien.h
+++ b/vm/alien.h
@@ -1,7 +1,7 @@
CELL allot_alien(CELL delegate, CELL displacement);
-DECLARE_PRIMITIVE(displaced_alien);
-DECLARE_PRIMITIVE(alien_address);
+void primitive_displaced_alien(void);
+void primitive_alien_address(void);
DLLEXPORT void *alien_offset(CELL object);
@@ -10,32 +10,32 @@ void fixup_alien(F_ALIEN* d);
DLLEXPORT void *unbox_alien(void);
DLLEXPORT void box_alien(void *ptr);
-DECLARE_PRIMITIVE(alien_signed_cell);
-DECLARE_PRIMITIVE(set_alien_signed_cell);
-DECLARE_PRIMITIVE(alien_unsigned_cell);
-DECLARE_PRIMITIVE(set_alien_unsigned_cell);
-DECLARE_PRIMITIVE(alien_signed_8);
-DECLARE_PRIMITIVE(set_alien_signed_8);
-DECLARE_PRIMITIVE(alien_unsigned_8);
-DECLARE_PRIMITIVE(set_alien_unsigned_8);
-DECLARE_PRIMITIVE(alien_signed_4);
-DECLARE_PRIMITIVE(set_alien_signed_4);
-DECLARE_PRIMITIVE(alien_unsigned_4);
-DECLARE_PRIMITIVE(set_alien_unsigned_4);
-DECLARE_PRIMITIVE(alien_signed_2);
-DECLARE_PRIMITIVE(set_alien_signed_2);
-DECLARE_PRIMITIVE(alien_unsigned_2);
-DECLARE_PRIMITIVE(set_alien_unsigned_2);
-DECLARE_PRIMITIVE(alien_signed_1);
-DECLARE_PRIMITIVE(set_alien_signed_1);
-DECLARE_PRIMITIVE(alien_unsigned_1);
-DECLARE_PRIMITIVE(set_alien_unsigned_1);
-DECLARE_PRIMITIVE(alien_float);
-DECLARE_PRIMITIVE(set_alien_float);
-DECLARE_PRIMITIVE(alien_double);
-DECLARE_PRIMITIVE(set_alien_double);
-DECLARE_PRIMITIVE(alien_cell);
-DECLARE_PRIMITIVE(set_alien_cell);
+void primitive_alien_signed_cell(void);
+void primitive_set_alien_signed_cell(void);
+void primitive_alien_unsigned_cell(void);
+void primitive_set_alien_unsigned_cell(void);
+void primitive_alien_signed_8(void);
+void primitive_set_alien_signed_8(void);
+void primitive_alien_unsigned_8(void);
+void primitive_set_alien_unsigned_8(void);
+void primitive_alien_signed_4(void);
+void primitive_set_alien_signed_4(void);
+void primitive_alien_unsigned_4(void);
+void primitive_set_alien_unsigned_4(void);
+void primitive_alien_signed_2(void);
+void primitive_set_alien_signed_2(void);
+void primitive_alien_unsigned_2(void);
+void primitive_set_alien_unsigned_2(void);
+void primitive_alien_signed_1(void);
+void primitive_set_alien_signed_1(void);
+void primitive_alien_unsigned_1(void);
+void primitive_set_alien_unsigned_1(void);
+void primitive_alien_float(void);
+void primitive_set_alien_float(void);
+void primitive_alien_double(void);
+void primitive_set_alien_double(void);
+void primitive_alien_cell(void);
+void primitive_set_alien_cell(void);
DLLEXPORT void to_value_struct(CELL src, void *dest, CELL size);
DLLEXPORT void box_value_struct(void *src, CELL size);
@@ -43,7 +43,7 @@ DLLEXPORT void box_small_struct(CELL x, CELL y, CELL size);
DEFINE_UNTAG(F_DLL,DLL_TYPE,dll)
-DECLARE_PRIMITIVE(dlopen);
-DECLARE_PRIMITIVE(dlsym);
-DECLARE_PRIMITIVE(dlclose);
-DECLARE_PRIMITIVE(dll_validp);
+void primitive_dlopen(void);
+void primitive_dlsym(void);
+void primitive_dlclose(void);
+void primitive_dll_validp(void);
diff --git a/vm/callstack.c b/vm/callstack.c
index b7e99b418c..dfa7dd5f4a 100755
--- a/vm/callstack.c
+++ b/vm/callstack.c
@@ -6,11 +6,6 @@ F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom)
stack_chain->callstack_bottom = callstack_bottom;
}
-F_FASTCALL __attribute__((noinline)) void save_callstack_top(F_STACK_FRAME *callstack_top)
-{
- stack_chain->callstack_top = callstack_top;
-}
-
void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator)
{
F_STACK_FRAME *frame = (F_STACK_FRAME *)bottom - 1;
@@ -68,7 +63,7 @@ F_STACK_FRAME *capture_start(void)
return frame + 1;
}
-DEFINE_PRIMITIVE(callstack)
+void primitive_callstack(void)
{
F_STACK_FRAME *top = capture_start();
F_STACK_FRAME *bottom = stack_chain->callstack_bottom;
@@ -82,7 +77,7 @@ DEFINE_PRIMITIVE(callstack)
dpush(tag_object(callstack));
}
-DEFINE_PRIMITIVE(set_callstack)
+void primitive_set_callstack(void)
{
F_CALLSTACK *stack = untag_callstack(dpop());
@@ -158,7 +153,7 @@ void stack_frame_to_array(F_STACK_FRAME *frame)
set_array_nth(array,frame_index++,frame_scan(frame));
}
-DEFINE_PRIMITIVE(callstack_to_array)
+void primitive_callstack_to_array(void)
{
F_CALLSTACK *stack = untag_callstack(dpop());
@@ -190,7 +185,7 @@ F_STACK_FRAME *innermost_stack_frame(F_CALLSTACK *callstack)
/* Some primitives implementing a limited form of callstack mutation.
Used by the single stepper. */
-DEFINE_PRIMITIVE(innermost_stack_frame_quot)
+void primitive_innermost_stack_frame_quot(void)
{
F_STACK_FRAME *inner = innermost_stack_frame(
untag_callstack(dpop()));
@@ -199,7 +194,7 @@ DEFINE_PRIMITIVE(innermost_stack_frame_quot)
dpush(frame_executing(inner));
}
-DEFINE_PRIMITIVE(innermost_stack_frame_scan)
+void primitive_innermost_stack_frame_scan(void)
{
F_STACK_FRAME *inner = innermost_stack_frame(
untag_callstack(dpop()));
@@ -208,7 +203,7 @@ DEFINE_PRIMITIVE(innermost_stack_frame_scan)
dpush(frame_scan(inner));
}
-DEFINE_PRIMITIVE(set_innermost_stack_frame_quot)
+void primitive_set_innermost_stack_frame_quot(void)
{
F_CALLSTACK *callstack = untag_callstack(dpop());
F_QUOTATION *quot = untag_quotation(dpop());
diff --git a/vm/callstack.h b/vm/callstack.h
index 6c38cd0117..da0748b071 100755
--- a/vm/callstack.h
+++ b/vm/callstack.h
@@ -1,5 +1,4 @@
F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom);
-F_FASTCALL __attribute__((noinline)) void save_callstack_top(F_STACK_FRAME *callstack_top);
#define FIRST_STACK_FRAME(stack) (F_STACK_FRAME *)((stack) + 1)
@@ -14,11 +13,11 @@ CELL frame_executing(F_STACK_FRAME *frame);
CELL frame_scan(F_STACK_FRAME *frame);
CELL frame_type(F_STACK_FRAME *frame);
-DECLARE_PRIMITIVE(callstack);
-DECLARE_PRIMITIVE(set_datastack);
-DECLARE_PRIMITIVE(set_retainstack);
-DECLARE_PRIMITIVE(set_callstack);
-DECLARE_PRIMITIVE(callstack_to_array);
-DECLARE_PRIMITIVE(innermost_stack_frame_quot);
-DECLARE_PRIMITIVE(innermost_stack_frame_scan);
-DECLARE_PRIMITIVE(set_innermost_stack_frame_quot);
+void primitive_callstack(void);
+void primitive_set_datastack(void);
+void primitive_set_retainstack(void);
+void primitive_set_callstack(void);
+void primitive_callstack_to_array(void);
+void primitive_innermost_stack_frame_quot(void);
+void primitive_innermost_stack_frame_scan(void);
+void primitive_set_innermost_stack_frame_quot(void);
diff --git a/vm/code_gc.c b/vm/code_gc.c
index 03661999c5..bd6384408b 100755
--- a/vm/code_gc.c
+++ b/vm/code_gc.c
@@ -295,7 +295,7 @@ void recursive_mark(F_BLOCK *block)
}
/* Push the free space and total size of the code heap */
-DEFINE_PRIMITIVE(code_room)
+void primitive_code_room(void)
{
CELL used, total_free, max_free;
heap_usage(&code_heap,&used,&total_free,&max_free);
diff --git a/vm/code_gc.h b/vm/code_gc.h
index f93cba9c7a..72ad8d451c 100644
--- a/vm/code_gc.h
+++ b/vm/code_gc.h
@@ -82,4 +82,4 @@ void recursive_mark(F_BLOCK *block);
void dump_heap(F_HEAP *heap);
void compact_code_heap(void);
-DECLARE_PRIMITIVE(code_room);
+void primitive_code_room(void);
diff --git a/vm/code_heap.c b/vm/code_heap.c
index 1435caa9d2..2268df27e3 100755
--- a/vm/code_heap.c
+++ b/vm/code_heap.c
@@ -68,9 +68,11 @@ INLINE CELL compute_code_rel(F_REL *rel,
case RT_XT:
return (CELL)untag_word(get(CREF(literals_start,REL_ARGUMENT(rel))))->xt;
case RT_HERE:
- return rel->offset + code_start;
+ return rel->offset + code_start + (short)REL_ARGUMENT(rel);
case RT_LABEL:
return code_start + REL_ARGUMENT(rel);
+ case RT_STACK_CHAIN:
+ return (CELL)&stack_chain;
default:
critical_error("Bad rel type",rel->type);
return -1; /* Can't happen */
@@ -322,7 +324,7 @@ void default_word_code(F_WORD *word, bool relocate)
word->compiledp = F;
}
-DEFINE_PRIMITIVE(modify_code_heap)
+void primitive_modify_code_heap(void)
{
bool rescan_code_heap = to_boolean(dpop());
F_ARRAY *alist = untag_array(dpop());
diff --git a/vm/code_heap.h b/vm/code_heap.h
index c3b476c4b5..7b1545ddf5 100755
--- a/vm/code_heap.h
+++ b/vm/code_heap.h
@@ -13,8 +13,10 @@ typedef enum {
RT_HERE,
/* a local label */
RT_LABEL,
- /* immeditae literal */
- RT_IMMEDIATE
+ /* immediate literal */
+ RT_IMMEDIATE,
+ /* address of stack_chain var */
+ RT_STACK_CHAIN
} F_RELTYPE;
typedef enum {
@@ -71,4 +73,4 @@ F_COMPILED *add_compiled_block(
CELL compiled_code_format(void);
bool stack_traces_p(void);
-DECLARE_PRIMITIVE(modify_code_heap);
+void primitive_modify_code_heap(void);
diff --git a/vm/data_gc.c b/vm/data_gc.c
index 5342ff04d9..cf1632811c 100755
--- a/vm/data_gc.c
+++ b/vm/data_gc.c
@@ -250,13 +250,13 @@ CELL unaligned_object_size(CELL pointer)
}
}
-DEFINE_PRIMITIVE(size)
+void primitive_size(void)
{
box_unsigned_cell(object_size(dpop()));
}
/* Push memory usage statistics in data heap */
-DEFINE_PRIMITIVE(data_room)
+void primitive_data_room(void)
{
F_ARRAY *a = allot_array(ARRAY_TYPE,data_heap->gen_count * 2,F);
int gen;
@@ -281,7 +281,7 @@ void begin_scan(void)
gc_off = true;
}
-DEFINE_PRIMITIVE(begin_scan)
+void primitive_begin_scan(void)
{
gc();
begin_scan();
@@ -306,13 +306,13 @@ CELL next_object(void)
}
/* Push object at heap scan cursor and advance; pushes f when done */
-DEFINE_PRIMITIVE(next_object)
+void primitive_next_object(void)
{
dpush(next_object());
}
/* Re-enables GC */
-DEFINE_PRIMITIVE(end_scan)
+void primitive_end_scan(void)
{
gc_off = false;
}
@@ -911,12 +911,12 @@ void minor_gc(void)
garbage_collection(NURSERY,false,0);
}
-DEFINE_PRIMITIVE(gc)
+void primitive_gc(void)
{
gc();
}
-DEFINE_PRIMITIVE(gc_stats)
+void primitive_gc_stats(void)
{
GROWABLE_ARRAY(stats);
@@ -945,12 +945,12 @@ DEFINE_PRIMITIVE(gc_stats)
dpush(stats);
}
-DEFINE_PRIMITIVE(gc_reset)
+void primitive_gc_reset(void)
{
gc_reset();
}
-DEFINE_PRIMITIVE(become)
+void primitive_become(void)
{
F_ARRAY *new_objects = untag_array(dpop());
F_ARRAY *old_objects = untag_array(dpop());
diff --git a/vm/data_gc.h b/vm/data_gc.h
index 3c21695c2c..0d63cc6bfe 100755
--- a/vm/data_gc.h
+++ b/vm/data_gc.h
@@ -13,11 +13,11 @@ CELL binary_payload_start(CELL pointer);
void begin_scan(void);
CELL next_object(void);
-DECLARE_PRIMITIVE(data_room);
-DECLARE_PRIMITIVE(size);
-DECLARE_PRIMITIVE(begin_scan);
-DECLARE_PRIMITIVE(next_object);
-DECLARE_PRIMITIVE(end_scan);
+void primitive_data_room(void);
+void primitive_size(void);
+void primitive_begin_scan(void);
+void primitive_next_object(void);
+void primitive_end_scan(void);
void gc(void);
DLLEXPORT void minor_gc(void);
@@ -388,9 +388,9 @@ INLINE void* allot_object(CELL type, CELL a)
CELL collect_next(CELL scan);
-DECLARE_PRIMITIVE(gc);
-DECLARE_PRIMITIVE(gc_stats);
-DECLARE_PRIMITIVE(gc_reset);
-DECLARE_PRIMITIVE(become);
+void primitive_gc(void);
+void primitive_gc_stats(void);
+void primitive_gc_reset(void);
+void primitive_become(void);
CELL find_all_words(void);
diff --git a/vm/debug.c b/vm/debug.c
index 2550931c72..41205d4aff 100755
--- a/vm/debug.c
+++ b/vm/debug.c
@@ -474,7 +474,7 @@ void factorbug(void)
}
}
-DEFINE_PRIMITIVE(die)
+void primitive_die(void)
{
fprintf(stderr,"The die word was called by the library. Unless you called it yourself,\n");
fprintf(stderr,"you have triggered a bug in Factor. Please report.\n");
diff --git a/vm/debug.h b/vm/debug.h
index 547fdba436..594d8ec919 100755
--- a/vm/debug.h
+++ b/vm/debug.h
@@ -6,4 +6,4 @@ void dump_zone(F_ZONE *z);
bool fep_disabled;
-DECLARE_PRIMITIVE(die);
+void primitive_die(void);
diff --git a/vm/errors.c b/vm/errors.c
index 36072920fe..fe6e79be6d 100755
--- a/vm/errors.c
+++ b/vm/errors.c
@@ -142,19 +142,19 @@ void misc_signal_handler_impl(void)
signal_error(signal_number,signal_callstack_top);
}
-DEFINE_PRIMITIVE(throw)
+void primitive_throw(void)
{
dpop();
throw_impl(dpop(),stack_chain->callstack_top);
}
-DEFINE_PRIMITIVE(call_clear)
+void primitive_call_clear(void)
{
throw_impl(dpop(),stack_chain->callstack_bottom);
}
/* For testing purposes */
-DEFINE_PRIMITIVE(unimplemented)
+void primitive_unimplemented(void)
{
not_implemented_error();
}
diff --git a/vm/errors.h b/vm/errors.h
index 22cd6533c3..c7f8bc8712 100755
--- a/vm/errors.h
+++ b/vm/errors.h
@@ -22,7 +22,7 @@ typedef enum
void out_of_memory(void);
void fatal_error(char* msg, CELL tagged);
void critical_error(char* msg, CELL tagged);
-DECLARE_PRIMITIVE(die);
+void primitive_die(void);
void throw_error(CELL error, F_STACK_FRAME *native_stack);
void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, F_STACK_FRAME *native_stack);
@@ -32,8 +32,8 @@ void signal_error(int signal, F_STACK_FRAME *native_stack);
void type_error(CELL type, CELL tagged);
void not_implemented_error(void);
-DECLARE_PRIMITIVE(throw);
-DECLARE_PRIMITIVE(call_clear);
+void primitive_throw(void);
+void primitive_call_clear(void);
INLINE void type_check(CELL type, CELL tagged)
{
@@ -57,4 +57,4 @@ void memory_signal_handler_impl(void);
void divide_by_zero_signal_handler_impl(void);
void misc_signal_handler_impl(void);
-DECLARE_PRIMITIVE(unimplemented);
+void primitive_unimplemented(void);
diff --git a/vm/image.c b/vm/image.c
index 62f9e1c906..289c1e94c8 100755
--- a/vm/image.c
+++ b/vm/image.c
@@ -161,7 +161,7 @@ bool save_image(const F_CHAR *filename)
return true;
}
-DEFINE_PRIMITIVE(save_image)
+void primitive_save_image(void)
{
/* do a full GC to push everything into tenured space */
gc();
@@ -184,7 +184,7 @@ void strip_compiled_quotations(void)
gc_off = false;
}
-DEFINE_PRIMITIVE(save_image_and_exit)
+void primitive_save_image_and_exit(void)
{
/* We unbox this before doing anything else. This is the only point
where we might throw an error, so we have to throw an error here since
diff --git a/vm/image.h b/vm/image.h
index 9e582fc6c6..6e1b03af0d 100755
--- a/vm/image.h
+++ b/vm/image.h
@@ -40,8 +40,8 @@ void load_image(F_PARAMETERS *p);
void init_objects(F_HEADER *h);
bool save_image(const F_CHAR *file);
-DECLARE_PRIMITIVE(save_image);
-DECLARE_PRIMITIVE(save_image_and_exit);
+void primitive_save_image(void);
+void primitive_save_image_and_exit(void);
/* relocation base of currently loaded image's data heap */
CELL data_relocation_base;
diff --git a/vm/io.c b/vm/io.c
index bc561f5e5b..bad4854775 100755
--- a/vm/io.c
+++ b/vm/io.c
@@ -29,7 +29,7 @@ void io_error(void)
general_error(ERROR_IO,error,F,NULL);
}
-DEFINE_PRIMITIVE(fopen)
+void primitive_fopen(void)
{
char *mode = unbox_char_string();
REGISTER_C_STRING(mode);
@@ -49,7 +49,7 @@ DEFINE_PRIMITIVE(fopen)
}
}
-DEFINE_PRIMITIVE(fgetc)
+void primitive_fgetc(void)
{
FILE* file = unbox_alien();
@@ -74,7 +74,7 @@ DEFINE_PRIMITIVE(fgetc)
}
}
-DEFINE_PRIMITIVE(fread)
+void primitive_fread(void)
{
FILE* file = unbox_alien();
CELL size = unbox_array_size();
@@ -116,7 +116,7 @@ DEFINE_PRIMITIVE(fread)
}
}
-DEFINE_PRIMITIVE(fputc)
+void primitive_fputc(void)
{
FILE *file = unbox_alien();
F_FIXNUM ch = to_fixnum(dpop());
@@ -134,7 +134,7 @@ DEFINE_PRIMITIVE(fputc)
}
}
-DEFINE_PRIMITIVE(fwrite)
+void primitive_fwrite(void)
{
FILE *file = unbox_alien();
F_BYTE_ARRAY *text = untag_byte_array(dpop());
@@ -163,7 +163,7 @@ DEFINE_PRIMITIVE(fwrite)
}
}
-DEFINE_PRIMITIVE(fflush)
+void primitive_fflush(void)
{
FILE *file = unbox_alien();
for(;;)
@@ -175,7 +175,7 @@ DEFINE_PRIMITIVE(fflush)
}
}
-DEFINE_PRIMITIVE(fclose)
+void primitive_fclose(void)
{
FILE *file = unbox_alien();
for(;;)
diff --git a/vm/io.h b/vm/io.h
index f4af9b8bec..08c9dd7807 100755
--- a/vm/io.h
+++ b/vm/io.h
@@ -3,15 +3,15 @@ void io_error(void);
int err_no(void);
void clear_err_no(void);
-DECLARE_PRIMITIVE(fopen);
-DECLARE_PRIMITIVE(fgetc);
-DECLARE_PRIMITIVE(fread);
-DECLARE_PRIMITIVE(fputc);
-DECLARE_PRIMITIVE(fwrite);
-DECLARE_PRIMITIVE(fflush);
-DECLARE_PRIMITIVE(fclose);
+void primitive_fopen(void);
+void primitive_fgetc(void);
+void primitive_fread(void);
+void primitive_fputc(void);
+void primitive_fwrite(void);
+void primitive_fflush(void);
+void primitive_fclose(void);
/* Platform specific primitives */
-DECLARE_PRIMITIVE(open_file);
-DECLARE_PRIMITIVE(existsp);
-DECLARE_PRIMITIVE(read_dir);
+void primitive_open_file(void);
+void primitive_existsp(void);
+void primitive_read_dir(void);
diff --git a/vm/math.c b/vm/math.c
index 7d3b64ed39..388a472f2e 100644
--- a/vm/math.c
+++ b/vm/math.c
@@ -21,12 +21,12 @@ CELL to_cell(CELL tagged)
return (CELL)to_fixnum(tagged);
}
-DEFINE_PRIMITIVE(bignum_to_fixnum)
+void primitive_bignum_to_fixnum(void)
{
drepl(tag_fixnum(bignum_to_fixnum(untag_object(dpeek()))));
}
-DEFINE_PRIMITIVE(float_to_fixnum)
+void primitive_float_to_fixnum(void)
{
drepl(tag_fixnum(float_to_fixnum(dpeek())));
}
@@ -35,13 +35,13 @@ DEFINE_PRIMITIVE(float_to_fixnum)
F_FIXNUM y = untag_fixnum_fast(dpop()); \
F_FIXNUM x = untag_fixnum_fast(dpop());
-DEFINE_PRIMITIVE(fixnum_add)
+void primitive_fixnum_add(void)
{
POP_FIXNUMS(x,y)
box_signed_cell(x + y);
}
-DEFINE_PRIMITIVE(fixnum_subtract)
+void primitive_fixnum_subtract(void)
{
POP_FIXNUMS(x,y)
box_signed_cell(x - y);
@@ -49,7 +49,7 @@ DEFINE_PRIMITIVE(fixnum_subtract)
/* Multiply two integers, and trap overflow.
Thanks to David Blaikie (The_Vulture from freenode #java) for the hint. */
-DEFINE_PRIMITIVE(fixnum_multiply)
+void primitive_fixnum_multiply(void)
{
POP_FIXNUMS(x,y)
@@ -72,13 +72,13 @@ DEFINE_PRIMITIVE(fixnum_multiply)
}
}
-DEFINE_PRIMITIVE(fixnum_divint)
+void primitive_fixnum_divint(void)
{
POP_FIXNUMS(x,y)
box_signed_cell(x / y);
}
-DEFINE_PRIMITIVE(fixnum_divmod)
+void primitive_fixnum_divmod(void)
{
POP_FIXNUMS(x,y)
box_signed_cell(x / y);
@@ -90,7 +90,7 @@ DEFINE_PRIMITIVE(fixnum_divmod)
* If we're shifting right by n bits, we won't overflow as long as none of the
* high WORD_SIZE-TAG_BITS-n bits are set.
*/
-DEFINE_PRIMITIVE(fixnum_shift)
+void primitive_fixnum_shift(void)
{
POP_FIXNUMS(x,y)
@@ -122,12 +122,12 @@ DEFINE_PRIMITIVE(fixnum_shift)
}
/* Bignums */
-DEFINE_PRIMITIVE(fixnum_to_bignum)
+void primitive_fixnum_to_bignum(void)
{
drepl(tag_bignum(fixnum_to_bignum(untag_fixnum_fast(dpeek()))));
}
-DEFINE_PRIMITIVE(float_to_bignum)
+void primitive_float_to_bignum(void)
{
drepl(tag_bignum(float_to_bignum(dpeek())));
}
@@ -136,37 +136,37 @@ DEFINE_PRIMITIVE(float_to_bignum)
F_ARRAY *y = untag_object(dpop()); \
F_ARRAY *x = untag_object(dpop());
-DEFINE_PRIMITIVE(bignum_eq)
+void primitive_bignum_eq(void)
{
POP_BIGNUMS(x,y);
box_boolean(bignum_equal_p(x,y));
}
-DEFINE_PRIMITIVE(bignum_add)
+void primitive_bignum_add(void)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_add(x,y)));
}
-DEFINE_PRIMITIVE(bignum_subtract)
+void primitive_bignum_subtract(void)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_subtract(x,y)));
}
-DEFINE_PRIMITIVE(bignum_multiply)
+void primitive_bignum_multiply(void)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_multiply(x,y)));
}
-DEFINE_PRIMITIVE(bignum_divint)
+void primitive_bignum_divint(void)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_quotient(x,y)));
}
-DEFINE_PRIMITIVE(bignum_divmod)
+void primitive_bignum_divmod(void)
{
F_ARRAY *q, *r;
POP_BIGNUMS(x,y);
@@ -175,74 +175,74 @@ DEFINE_PRIMITIVE(bignum_divmod)
dpush(tag_bignum(r));
}
-DEFINE_PRIMITIVE(bignum_mod)
+void primitive_bignum_mod(void)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_remainder(x,y)));
}
-DEFINE_PRIMITIVE(bignum_and)
+void primitive_bignum_and(void)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_bitwise_and(x,y)));
}
-DEFINE_PRIMITIVE(bignum_or)
+void primitive_bignum_or(void)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_bitwise_ior(x,y)));
}
-DEFINE_PRIMITIVE(bignum_xor)
+void primitive_bignum_xor(void)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_bitwise_xor(x,y)));
}
-DEFINE_PRIMITIVE(bignum_shift)
+void primitive_bignum_shift(void)
{
F_FIXNUM y = to_fixnum(dpop());
F_ARRAY* x = untag_object(dpop());
dpush(tag_bignum(bignum_arithmetic_shift(x,y)));
}
-DEFINE_PRIMITIVE(bignum_less)
+void primitive_bignum_less(void)
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) == bignum_comparison_less);
}
-DEFINE_PRIMITIVE(bignum_lesseq)
+void primitive_bignum_lesseq(void)
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) != bignum_comparison_greater);
}
-DEFINE_PRIMITIVE(bignum_greater)
+void primitive_bignum_greater(void)
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) == bignum_comparison_greater);
}
-DEFINE_PRIMITIVE(bignum_greatereq)
+void primitive_bignum_greatereq(void)
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) != bignum_comparison_less);
}
-DEFINE_PRIMITIVE(bignum_not)
+void primitive_bignum_not(void)
{
drepl(tag_bignum(bignum_bitwise_not(untag_object(dpeek()))));
}
-DEFINE_PRIMITIVE(bignum_bitp)
+void primitive_bignum_bitp(void)
{
F_FIXNUM bit = to_fixnum(dpop());
F_ARRAY *x = untag_object(dpop());
box_boolean(bignum_logbitp(bit,x));
}
-DEFINE_PRIMITIVE(bignum_log2)
+void primitive_bignum_log2(void)
{
drepl(tag_bignum(bignum_integer_length(untag_object(dpeek()))));
}
@@ -253,7 +253,7 @@ unsigned int bignum_producer(unsigned int digit)
return *(ptr + digit);
}
-DEFINE_PRIMITIVE(byte_array_to_bignum)
+void primitive_byte_array_to_bignum(void)
{
type_check(BYTE_ARRAY_TYPE,dpeek());
CELL n_digits = array_capacity(untag_object(dpeek()));
@@ -383,7 +383,7 @@ CELL unbox_array_size(void)
/* Does not reduce to lowest terms, so should only be used by math
library implementation, to avoid breaking invariants. */
-DEFINE_PRIMITIVE(from_fraction)
+void primitive_from_fraction(void)
{
F_RATIO* ratio = allot_object(RATIO_TYPE,sizeof(F_RATIO));
ratio->denominator = dpop();
@@ -392,17 +392,17 @@ DEFINE_PRIMITIVE(from_fraction)
}
/* Floats */
-DEFINE_PRIMITIVE(fixnum_to_float)
+void primitive_fixnum_to_float(void)
{
drepl(allot_float(fixnum_to_float(dpeek())));
}
-DEFINE_PRIMITIVE(bignum_to_float)
+void primitive_bignum_to_float(void)
{
drepl(allot_float(bignum_to_float(dpeek())));
}
-DEFINE_PRIMITIVE(str_to_float)
+void primitive_str_to_float(void)
{
char *c_str, *end;
double f;
@@ -418,7 +418,7 @@ DEFINE_PRIMITIVE(str_to_float)
drepl(allot_float(f));
}
-DEFINE_PRIMITIVE(float_to_str)
+void primitive_float_to_str(void)
{
char tmp[33];
snprintf(tmp,32,"%.16g",untag_float(dpop()));
@@ -430,82 +430,82 @@ DEFINE_PRIMITIVE(float_to_str)
double y = untag_float_fast(dpop()); \
double x = untag_float_fast(dpop());
-DEFINE_PRIMITIVE(float_eq)
+void primitive_float_eq(void)
{
POP_FLOATS(x,y);
box_boolean(x == y);
}
-DEFINE_PRIMITIVE(float_add)
+void primitive_float_add(void)
{
POP_FLOATS(x,y);
box_double(x + y);
}
-DEFINE_PRIMITIVE(float_subtract)
+void primitive_float_subtract(void)
{
POP_FLOATS(x,y);
box_double(x - y);
}
-DEFINE_PRIMITIVE(float_multiply)
+void primitive_float_multiply(void)
{
POP_FLOATS(x,y);
box_double(x * y);
}
-DEFINE_PRIMITIVE(float_divfloat)
+void primitive_float_divfloat(void)
{
POP_FLOATS(x,y);
box_double(x / y);
}
-DEFINE_PRIMITIVE(float_mod)
+void primitive_float_mod(void)
{
POP_FLOATS(x,y);
box_double(fmod(x,y));
}
-DEFINE_PRIMITIVE(float_less)
+void primitive_float_less(void)
{
POP_FLOATS(x,y);
box_boolean(x < y);
}
-DEFINE_PRIMITIVE(float_lesseq)
+void primitive_float_lesseq(void)
{
POP_FLOATS(x,y);
box_boolean(x <= y);
}
-DEFINE_PRIMITIVE(float_greater)
+void primitive_float_greater(void)
{
POP_FLOATS(x,y);
box_boolean(x > y);
}
-DEFINE_PRIMITIVE(float_greatereq)
+void primitive_float_greatereq(void)
{
POP_FLOATS(x,y);
box_boolean(x >= y);
}
-DEFINE_PRIMITIVE(float_bits)
+void primitive_float_bits(void)
{
box_unsigned_4(float_bits(untag_float(dpop())));
}
-DEFINE_PRIMITIVE(bits_float)
+void primitive_bits_float(void)
{
box_float(bits_float(to_cell(dpop())));
}
-DEFINE_PRIMITIVE(double_bits)
+void primitive_double_bits(void)
{
box_unsigned_8(double_bits(untag_float(dpop())));
}
-DEFINE_PRIMITIVE(bits_double)
+void primitive_bits_double(void)
{
box_double(bits_double(to_unsigned_8(dpop())));
}
@@ -532,7 +532,7 @@ void box_double(double flo)
/* Complex numbers */
-DEFINE_PRIMITIVE(from_rect)
+void primitive_from_rect(void)
{
F_COMPLEX* complex = allot_object(COMPLEX_TYPE,sizeof(F_COMPLEX));
complex->imaginary = dpop();
diff --git a/vm/math.h b/vm/math.h
index 07d7fa9199..4fa3c8d35f 100644
--- a/vm/math.h
+++ b/vm/math.h
@@ -6,15 +6,15 @@
DLLEXPORT F_FIXNUM to_fixnum(CELL tagged);
DLLEXPORT CELL to_cell(CELL tagged);
-DECLARE_PRIMITIVE(bignum_to_fixnum);
-DECLARE_PRIMITIVE(float_to_fixnum);
+void primitive_bignum_to_fixnum(void);
+void primitive_float_to_fixnum(void);
-DECLARE_PRIMITIVE(fixnum_add);
-DECLARE_PRIMITIVE(fixnum_subtract);
-DECLARE_PRIMITIVE(fixnum_multiply);
-DECLARE_PRIMITIVE(fixnum_divint);
-DECLARE_PRIMITIVE(fixnum_divmod);
-DECLARE_PRIMITIVE(fixnum_shift);
+void primitive_fixnum_add(void);
+void primitive_fixnum_subtract(void);
+void primitive_fixnum_multiply(void);
+void primitive_fixnum_divint(void);
+void primitive_fixnum_divmod(void);
+void primitive_fixnum_shift(void);
CELL bignum_zero;
CELL bignum_pos_one;
@@ -25,27 +25,27 @@ INLINE CELL tag_bignum(F_ARRAY* bignum)
return RETAG(bignum,BIGNUM_TYPE);
}
-DECLARE_PRIMITIVE(fixnum_to_bignum);
-DECLARE_PRIMITIVE(float_to_bignum);
-DECLARE_PRIMITIVE(bignum_eq);
-DECLARE_PRIMITIVE(bignum_add);
-DECLARE_PRIMITIVE(bignum_subtract);
-DECLARE_PRIMITIVE(bignum_multiply);
-DECLARE_PRIMITIVE(bignum_divint);
-DECLARE_PRIMITIVE(bignum_divmod);
-DECLARE_PRIMITIVE(bignum_mod);
-DECLARE_PRIMITIVE(bignum_and);
-DECLARE_PRIMITIVE(bignum_or);
-DECLARE_PRIMITIVE(bignum_xor);
-DECLARE_PRIMITIVE(bignum_shift);
-DECLARE_PRIMITIVE(bignum_less);
-DECLARE_PRIMITIVE(bignum_lesseq);
-DECLARE_PRIMITIVE(bignum_greater);
-DECLARE_PRIMITIVE(bignum_greatereq);
-DECLARE_PRIMITIVE(bignum_not);
-DECLARE_PRIMITIVE(bignum_bitp);
-DECLARE_PRIMITIVE(bignum_log2);
-DECLARE_PRIMITIVE(byte_array_to_bignum);
+void primitive_fixnum_to_bignum(void);
+void primitive_float_to_bignum(void);
+void primitive_bignum_eq(void);
+void primitive_bignum_add(void);
+void primitive_bignum_subtract(void);
+void primitive_bignum_multiply(void);
+void primitive_bignum_divint(void);
+void primitive_bignum_divmod(void);
+void primitive_bignum_mod(void);
+void primitive_bignum_and(void);
+void primitive_bignum_or(void);
+void primitive_bignum_xor(void);
+void primitive_bignum_shift(void);
+void primitive_bignum_less(void);
+void primitive_bignum_lesseq(void);
+void primitive_bignum_greater(void);
+void primitive_bignum_greatereq(void);
+void primitive_bignum_not(void);
+void primitive_bignum_bitp(void);
+void primitive_bignum_log2(void);
+void primitive_byte_array_to_bignum(void);
INLINE CELL allot_integer(F_FIXNUM x)
{
@@ -80,7 +80,7 @@ DLLEXPORT u64 to_unsigned_8(CELL obj);
CELL unbox_array_size(void);
-DECLARE_PRIMITIVE(from_fraction);
+void primitive_from_fraction(void);
INLINE double untag_float_fast(CELL tagged)
{
@@ -125,26 +125,26 @@ DLLEXPORT float to_float(CELL value);
DLLEXPORT void box_double(double flo);
DLLEXPORT double to_double(CELL value);
-DECLARE_PRIMITIVE(fixnum_to_float);
-DECLARE_PRIMITIVE(bignum_to_float);
-DECLARE_PRIMITIVE(str_to_float);
-DECLARE_PRIMITIVE(float_to_str);
-DECLARE_PRIMITIVE(float_to_bits);
+void primitive_fixnum_to_float(void);
+void primitive_bignum_to_float(void);
+void primitive_str_to_float(void);
+void primitive_float_to_str(void);
+void primitive_float_to_bits(void);
-DECLARE_PRIMITIVE(float_eq);
-DECLARE_PRIMITIVE(float_add);
-DECLARE_PRIMITIVE(float_subtract);
-DECLARE_PRIMITIVE(float_multiply);
-DECLARE_PRIMITIVE(float_divfloat);
-DECLARE_PRIMITIVE(float_mod);
-DECLARE_PRIMITIVE(float_less);
-DECLARE_PRIMITIVE(float_lesseq);
-DECLARE_PRIMITIVE(float_greater);
-DECLARE_PRIMITIVE(float_greatereq);
+void primitive_float_eq(void);
+void primitive_float_add(void);
+void primitive_float_subtract(void);
+void primitive_float_multiply(void);
+void primitive_float_divfloat(void);
+void primitive_float_mod(void);
+void primitive_float_less(void);
+void primitive_float_lesseq(void);
+void primitive_float_greater(void);
+void primitive_float_greatereq(void);
-DECLARE_PRIMITIVE(float_bits);
-DECLARE_PRIMITIVE(bits_float);
-DECLARE_PRIMITIVE(double_bits);
-DECLARE_PRIMITIVE(bits_double);
+void primitive_float_bits(void);
+void primitive_bits_float(void);
+void primitive_double_bits(void);
+void primitive_bits_double(void);
-DECLARE_PRIMITIVE(from_rect);
+void primitive_from_rect(void);
diff --git a/vm/os-unix.c b/vm/os-unix.c
index 4ca62e6623..c11962f6e1 100755
--- a/vm/os-unix.c
+++ b/vm/os-unix.c
@@ -55,7 +55,7 @@ void ffi_dlclose(F_DLL *dll)
dll->dll = NULL;
}
-DEFINE_PRIMITIVE(existsp)
+void primitive_existsp(void)
{
struct stat sb;
box_boolean(stat(unbox_char_string(),&sb) >= 0);
diff --git a/vm/os-windows-ce.c b/vm/os-windows-ce.c
index 9b73692aa0..02b51b82ed 100755
--- a/vm/os-windows-ce.c
+++ b/vm/os-windows-ce.c
@@ -27,7 +27,7 @@ char *getenv(char *name)
return 0; /* unreachable */
}
-DEFINE_PRIMITIVE(os_envs)
+void primitive_os_envs(void)
{
not_implemented_error();
}
diff --git a/vm/os-windows.c b/vm/os-windows.c
index c19aa5c4b5..fc289c288e 100755
--- a/vm/os-windows.c
+++ b/vm/os-windows.c
@@ -87,7 +87,7 @@ const F_CHAR *vm_executable_path(void)
return safe_strdup(full_path);
}
-DEFINE_PRIMITIVE(existsp)
+void primitive_existsp(void)
{
BY_HANDLE_FILE_INFORMATION bhfi;
diff --git a/vm/primitives.h b/vm/primitives.h
index 811b473acd..30e0a4af96 100644
--- a/vm/primitives.h
+++ b/vm/primitives.h
@@ -1,42 +1 @@
extern void *primitives[];
-
-/* Primitives are called with two parameters, the word itself and the current
-callstack pointer. The DEFINE_PRIMITIVE() macro takes care of boilerplate to
-save the current callstack pointer so that GC and other facilities can proceed
-to inspect Factor stack frames below the primitive's C stack frame.
-
-Usage:
-
-DEFINE_PRIMITIVE(name)
-{
- ... CODE ...
-}
-
-Becomes
-
-F_FASTCALL void primitive_name(CELL word, F_STACK_FRAME *callstack_top)
-{
- save_callstack_top(callstack_top);
- ... CODE ...
-}
-
-On x86, F_FASTCALL expands into a GCC declaration which forces the two
-parameters to be passed in registers. This simplifies the quotation compiler
-and support code in cpu-x86.S.
-
-We do the assignment of stack_chain->callstack_top in a ``noinline'' function
-to inhibit assignment re-ordering. */
-#define DEFINE_PRIMITIVE(name) \
- INLINE void primitive_##name##_impl(void); \
- \
- F_FASTCALL void primitive_##name(CELL word, F_STACK_FRAME *callstack_top) \
- { \
- save_callstack_top(callstack_top); \
- primitive_##name##_impl(); \
- } \
- \
- INLINE void primitive_##name##_impl(void) \
-
-/* Prototype for header files */
-#define DECLARE_PRIMITIVE(name) \
- F_FASTCALL void primitive_##name(CELL word, F_STACK_FRAME *callstack_top)
diff --git a/vm/profiler.c b/vm/profiler.c
index 250e5a996a..e3db67964f 100755
--- a/vm/profiler.c
+++ b/vm/profiler.c
@@ -79,7 +79,7 @@ void set_profiling(bool profiling)
iterate_code_heap(relocate_code_block);
}
-DEFINE_PRIMITIVE(profiling)
+void primitive_profiling(void)
{
set_profiling(to_boolean(dpop()));
}
diff --git a/vm/profiler.h b/vm/profiler.h
index d14ceb283b..26a3a78d4b 100755
--- a/vm/profiler.h
+++ b/vm/profiler.h
@@ -1,4 +1,4 @@
bool profiling_p;
-DECLARE_PRIMITIVE(profiling);
+void primitive_profiling(void);
F_COMPILED *compile_profiling_stub(F_WORD *word);
void update_word_xt(F_WORD *word);
diff --git a/vm/quotations.c b/vm/quotations.c
index b75d3f79e0..bf917aeec0 100755
--- a/vm/quotations.c
+++ b/vm/quotations.c
@@ -209,6 +209,7 @@ void jit_compile(CELL quot, bool relocate)
case FIXNUM_TYPE:
if(jit_primitive_call_p(untag_object(array),i))
{
+ EMIT(userenv[JIT_SAVE_STACK],0);
EMIT(userenv[JIT_PRIMITIVE],to_fixnum(obj));
i++;
@@ -344,6 +345,7 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
case FIXNUM_TYPE:
if(jit_primitive_call_p(untag_object(array),i))
{
+ COUNT(userenv[JIT_SAVE_STACK],i);
COUNT(userenv[JIT_PRIMITIVE],i);
i++;
@@ -412,7 +414,7 @@ F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack)
}
/* push a new quotation on the stack */
-DEFINE_PRIMITIVE(array_to_quotation)
+void primitive_array_to_quotation(void)
{
F_QUOTATION *quot = allot_object(QUOTATION_TYPE,sizeof(F_QUOTATION));
quot->array = dpeek();
@@ -421,7 +423,7 @@ DEFINE_PRIMITIVE(array_to_quotation)
drepl(tag_object(quot));
}
-DEFINE_PRIMITIVE(quotation_xt)
+void primitive_quotation_xt(void)
{
F_QUOTATION *quot = untag_quotation(dpeek());
drepl(allot_cell((CELL)quot->xt));
diff --git a/vm/quotations.h b/vm/quotations.h
index 0845957c0b..45bf78d14f 100755
--- a/vm/quotations.h
+++ b/vm/quotations.h
@@ -2,5 +2,5 @@ void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code);
void jit_compile(CELL quot, bool relocate);
F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack);
F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset);
-DECLARE_PRIMITIVE(array_to_quotation);
-DECLARE_PRIMITIVE(quotation_xt);
+void primitive_array_to_quotation(void);
+void primitive_quotation_xt(void);
diff --git a/vm/run.c b/vm/run.c
index c4a3e115c1..c7d93d29c8 100755
--- a/vm/run.c
+++ b/vm/run.c
@@ -105,13 +105,13 @@ bool stack_to_array(CELL bottom, CELL top)
}
}
-DEFINE_PRIMITIVE(datastack)
+void primitive_datastack(void)
{
if(!stack_to_array(ds_bot,ds))
general_error(ERROR_DS_UNDERFLOW,F,F,NULL);
}
-DEFINE_PRIMITIVE(retainstack)
+void primitive_retainstack(void)
{
if(!stack_to_array(rs_bot,rs))
general_error(ERROR_RS_UNDERFLOW,F,F,NULL);
@@ -125,45 +125,45 @@ CELL array_to_stack(F_ARRAY *array, CELL bottom)
return bottom + depth - CELLS;
}
-DEFINE_PRIMITIVE(set_datastack)
+void primitive_set_datastack(void)
{
ds = array_to_stack(untag_array(dpop()),ds_bot);
}
-DEFINE_PRIMITIVE(set_retainstack)
+void primitive_set_retainstack(void)
{
rs = array_to_stack(untag_array(dpop()),rs_bot);
}
-DEFINE_PRIMITIVE(getenv)
+void primitive_getenv(void)
{
F_FIXNUM e = untag_fixnum_fast(dpeek());
drepl(userenv[e]);
}
-DEFINE_PRIMITIVE(setenv)
+void primitive_setenv(void)
{
F_FIXNUM e = untag_fixnum_fast(dpop());
CELL value = dpop();
userenv[e] = value;
}
-DEFINE_PRIMITIVE(exit)
+void primitive_exit(void)
{
exit(to_fixnum(dpop()));
}
-DEFINE_PRIMITIVE(millis)
+void primitive_millis(void)
{
box_unsigned_8(current_millis());
}
-DEFINE_PRIMITIVE(sleep)
+void primitive_sleep(void)
{
sleep_millis(to_cell(dpop()));
}
-DEFINE_PRIMITIVE(set_slot)
+void primitive_set_slot(void)
{
F_FIXNUM slot = untag_fixnum_fast(dpop());
CELL obj = dpop();
diff --git a/vm/run.h b/vm/run.h
index 96e606e38c..2dbbcc8c06 100755
--- a/vm/run.h
+++ b/vm/run.h
@@ -48,8 +48,8 @@ typedef enum {
JIT_RETURN,
JIT_PROFILING,
JIT_PUSH_IMMEDIATE,
-
JIT_DECLARE_WORD = 42,
+ JIT_SAVE_STACK,
STACK_TRACES_ENV = 59,
@@ -226,18 +226,18 @@ DLLEXPORT void nest_stacks(void);
DLLEXPORT void unnest_stacks(void);
void init_stacks(CELL ds_size, CELL rs_size);
-DECLARE_PRIMITIVE(datastack);
-DECLARE_PRIMITIVE(retainstack);
-DECLARE_PRIMITIVE(getenv);
-DECLARE_PRIMITIVE(setenv);
-DECLARE_PRIMITIVE(exit);
-DECLARE_PRIMITIVE(os_env);
-DECLARE_PRIMITIVE(os_envs);
-DECLARE_PRIMITIVE(set_os_env);
-DECLARE_PRIMITIVE(unset_os_env);
-DECLARE_PRIMITIVE(set_os_envs);
-DECLARE_PRIMITIVE(millis);
-DECLARE_PRIMITIVE(sleep);
-DECLARE_PRIMITIVE(set_slot);
+void primitive_datastack(void);
+void primitive_retainstack(void);
+void primitive_getenv(void);
+void primitive_setenv(void);
+void primitive_exit(void);
+void primitive_os_env(void);
+void primitive_os_envs(void);
+void primitive_set_os_env(void);
+void primitive_unset_os_env(void);
+void primitive_set_os_envs(void);
+void primitive_millis(void);
+void primitive_sleep(void);
+void primitive_set_slot(void);
bool stage2;
diff --git a/vm/types.c b/vm/types.c
index 38fe3460e7..f1588465a4 100755
--- a/vm/types.c
+++ b/vm/types.c
@@ -29,7 +29,7 @@ CELL clone_object(CELL object)
}
}
-DEFINE_PRIMITIVE(clone)
+void primitive_clone(void)
{
drepl(clone_object(dpeek()));
}
@@ -68,7 +68,7 @@ F_WORD *allot_word(CELL vocab, CELL name)
}
/* <word> ( name vocabulary -- word ) */
-DEFINE_PRIMITIVE(word)
+void primitive_word(void)
{
CELL vocab = dpop();
CELL name = dpop();
@@ -76,7 +76,7 @@ DEFINE_PRIMITIVE(word)
}
/* word-xt ( word -- start end ) */
-DEFINE_PRIMITIVE(word_xt)
+void primitive_word_xt(void)
{
F_WORD *word = untag_word(dpop());
F_COMPILED *code = (profiling_p ? word->profiling : word->code);
@@ -84,7 +84,7 @@ DEFINE_PRIMITIVE(word_xt)
dpush(allot_cell((CELL)code + sizeof(F_COMPILED) + code->code_length));
}
-DEFINE_PRIMITIVE(wrapper)
+void primitive_wrapper(void)
{
F_WRAPPER *wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER));
wrapper->object = dpeek();
@@ -123,7 +123,7 @@ F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill)
}
/* push a new array on the stack */
-DEFINE_PRIMITIVE(array)
+void primitive_array(void)
{
CELL initial = dpop();
CELL size = unbox_array_size();
@@ -194,7 +194,7 @@ F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill)
return new_array;
}
-DEFINE_PRIMITIVE(resize_array)
+void primitive_resize_array(void)
{
F_ARRAY* array = untag_array(dpop());
CELL capacity = unbox_array_size();
@@ -259,7 +259,7 @@ F_BYTE_ARRAY *allot_byte_array(CELL size)
}
/* push a new byte array on the stack */
-DEFINE_PRIMITIVE(byte_array)
+void primitive_byte_array(void)
{
CELL size = unbox_array_size();
dpush(tag_object(allot_byte_array(size)));
@@ -280,7 +280,7 @@ F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity)
return new_array;
}
-DEFINE_PRIMITIVE(resize_byte_array)
+void primitive_resize_byte_array(void)
{
F_BYTE_ARRAY* array = untag_byte_array(dpop());
CELL capacity = unbox_array_size();
@@ -313,7 +313,7 @@ F_TUPLE *allot_tuple(F_TUPLE_LAYOUT *layout)
return tuple;
}
-DEFINE_PRIMITIVE(tuple)
+void primitive_tuple(void)
{
F_TUPLE_LAYOUT *layout = untag_object(dpop());
F_FIXNUM size = untag_fixnum_fast(layout->size);
@@ -327,7 +327,7 @@ DEFINE_PRIMITIVE(tuple)
}
/* push a new tuple on the stack, filling its slots from the stack */
-DEFINE_PRIMITIVE(tuple_boa)
+void primitive_tuple_boa(void)
{
F_TUPLE_LAYOUT *layout = untag_object(dpop());
F_FIXNUM size = untag_fixnum_fast(layout->size);
@@ -434,7 +434,7 @@ F_STRING *allot_string(CELL capacity, CELL fill)
return string;
}
-DEFINE_PRIMITIVE(string)
+void primitive_string(void)
{
CELL initial = to_cell(dpop());
CELL length = unbox_array_size();
@@ -477,7 +477,7 @@ F_STRING* reallot_string(F_STRING* string, CELL capacity, CELL fill)
return new_string;
}
-DEFINE_PRIMITIVE(resize_string)
+void primitive_resize_string(void)
{
F_STRING* string = untag_string(dpop());
CELL capacity = unbox_array_size();
@@ -544,7 +544,7 @@ F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size)
for(i = 0; i < capacity; i++) \
string[i] = string_nth(s,i); \
} \
- DEFINE_PRIMITIVE(type##_string_to_memory) \
+ void primitive_##type##_string_to_memory(void) \
{ \
type *address = unbox_alien(); \
F_STRING *str = untag_string(dpop()); \
@@ -576,14 +576,14 @@ F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size)
STRING_TO_MEMORY(char);
STRING_TO_MEMORY(u16);
-DEFINE_PRIMITIVE(string_nth)
+void primitive_string_nth(void)
{
F_STRING *string = untag_object(dpop());
CELL index = untag_fixnum_fast(dpop());
dpush(tag_fixnum(string_nth(string,index)));
}
-DEFINE_PRIMITIVE(set_string_nth)
+void primitive_set_string_nth(void)
{
F_STRING *string = untag_object(dpop());
CELL index = untag_fixnum_fast(dpop());
diff --git a/vm/types.h b/vm/types.h
index 6efae35f5e..ebbb8a2642 100755
--- a/vm/types.h
+++ b/vm/types.h
@@ -112,23 +112,23 @@ CELL allot_array_1(CELL obj);
CELL allot_array_2(CELL v1, CELL v2);
CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4);
-DECLARE_PRIMITIVE(array);
-DECLARE_PRIMITIVE(tuple);
-DECLARE_PRIMITIVE(tuple_boa);
-DECLARE_PRIMITIVE(tuple_layout);
-DECLARE_PRIMITIVE(byte_array);
-DECLARE_PRIMITIVE(clone);
+void primitive_array(void);
+void primitive_tuple(void);
+void primitive_tuple_boa(void);
+void primitive_tuple_layout(void);
+void primitive_byte_array(void);
+void primitive_clone(void);
F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill);
F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity);
-DECLARE_PRIMITIVE(resize_array);
-DECLARE_PRIMITIVE(resize_byte_array);
+void primitive_resize_array(void);
+void primitive_resize_byte_array(void);
F_STRING* allot_string_internal(CELL capacity);
F_STRING* allot_string(CELL capacity, CELL fill);
-DECLARE_PRIMITIVE(string);
+void primitive_string(void);
F_STRING *reallot_string(F_STRING *string, CELL capacity, CELL fill);
-DECLARE_PRIMITIVE(resize_string);
+void primitive_resize_string(void);
F_STRING *memory_to_char_string(const char *string, CELL length);
F_STRING *from_char_string(const char *c_string);
@@ -152,14 +152,14 @@ DLLEXPORT u16 *unbox_u16_string(void);
CELL string_nth(F_STRING* string, CELL index);
void set_string_nth(F_STRING* string, CELL index, CELL value);
-DECLARE_PRIMITIVE(string_nth);
-DECLARE_PRIMITIVE(set_string_nth);
+void primitive_string_nth(void);
+void primitive_set_string_nth(void);
F_WORD *allot_word(CELL vocab, CELL name);
-DECLARE_PRIMITIVE(word);
-DECLARE_PRIMITIVE(word_xt);
+void primitive_word(void);
+void primitive_word_xt(void);
-DECLARE_PRIMITIVE(wrapper);
+void primitive_wrapper(void);
/* Macros to simulate a vector in C */
#define GROWABLE_ARRAY(result) \
From ef6206d4bb167804d1b10727c0b87ccafcc422ef Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 13 Nov 2008 03:51:04 -0600
Subject: [PATCH 049/157] Try to optimize generic dispatch to speed up + on
fixnums, nth on arrays for example
---
core/generic/math/math.factor | 19 +++++++++++--------
core/generic/standard/engines/tag/tag.factor | 10 ++++++----
2 files changed, 17 insertions(+), 12 deletions(-)
diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor
index 077795c4b7..ebe1c08cb3 100644
--- a/core/generic/math/math.factor
+++ b/core/generic/math/math.factor
@@ -3,7 +3,7 @@
USING: arrays generic hashtables kernel kernel.private math
namespaces make sequences words quotations layouts combinators
sequences.private classes classes.builtin classes.algebra
-definitions math.order ;
+definitions math.order math.private ;
IN: generic.math
PREDICATE: math-class < class
@@ -62,13 +62,17 @@ ERROR: no-math-method left right generic ;
2drop object-method
] if ;
+SYMBOL: picker
+
: math-vtable ( picker quot -- quot )
[
- >r
- , \ tag ,
- num-tags get [ bootstrap-type>class ]
- r> compose map ,
- \ dispatch ,
+ swap picker set
+ picker get , [ tag 0 eq? ] %
+ num-tags get swap [ bootstrap-type>class ] prepose map
+ unclip ,
+ [
+ picker get , [ tag 1 fixnum-fast ] % , \ dispatch ,
+ ] [ ] make , \ if ,
] [ ] make ; inline
TUPLE: math-combination ;
@@ -85,8 +89,7 @@ M: math-combination perform-combination
] [
over object-method
] if nip
- ] math-vtable nip
- define ;
+ ] math-vtable nip define ;
PREDICATE: math-generic < generic ( word -- ? )
"combination" word-prop math-combination? ;
diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor
index 87e2f1c9b1..d1bc6d7417 100644
--- a/core/generic/standard/engines/tag/tag.factor
+++ b/core/generic/standard/engines/tag/tag.factor
@@ -22,13 +22,14 @@ C: <lo-tag-dispatch-engine> lo-tag-dispatch-engine
"type" word-prop
] if ;
+: sort-tags ( assoc -- alist ) >alist sort-keys reverse ;
+
M: lo-tag-dispatch-engine engine>quot
methods>> engines>quots*
[ >r lo-tag-number r> ] assoc-map
[
picker % [ tag ] % [
- >alist sort-keys reverse
- linear-dispatch-quot
+ sort-tags linear-dispatch-quot
] [
num-tags get direct-dispatch-quot
] if-small? %
@@ -51,10 +52,11 @@ C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
\ hi-tag def>> ;
M: hi-tag-dispatch-engine engine>quot
- methods>> engines>quots* [ >r hi-tag-number r> ] assoc-map
+ methods>> engines>quots*
+ [ >r hi-tag-number r> ] assoc-map
[
picker % hi-tag-quot % [
- linear-dispatch-quot
+ sort-tags linear-dispatch-quot
] [
num-tags get , \ fixnum-fast ,
[ >r num-tags get - r> ] assoc-map
From b1aa3697cb0382729dd78ac6e7ae73ff72833a60 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 13 Nov 2008 03:52:01 -0600
Subject: [PATCH 050/157] Emit branches in the same order they're written in
code
---
basis/compiler/cfg/linearization/linearization.factor | 4 ++--
basis/compiler/cfg/rpo/rpo.factor | 5 ++++-
2 files changed, 6 insertions(+), 3 deletions(-)
diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor
index d397c9d448..7433df9617 100644
--- a/basis/compiler/cfg/linearization/linearization.factor
+++ b/basis/compiler/cfg/linearization/linearization.factor
@@ -43,8 +43,8 @@ M: ##branch linearize-insn
: binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc )
[ (binary-conditional) ]
- [ drop dup successors>> first useless-branch? ] 2bi
- [ [ number>> ] 3dip negate-cc ] [ [ swap number>> ] 3dip ] if ;
+ [ drop dup successors>> second useless-branch? ] 2bi
+ [ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ;
M: ##compare-branch linearize-insn
binary-conditional _compare-branch emit-branch ;
diff --git a/basis/compiler/cfg/rpo/rpo.factor b/basis/compiler/cfg/rpo/rpo.factor
index 7f4b09e68f..158903b4bf 100644
--- a/basis/compiler/cfg/rpo/rpo.factor
+++ b/basis/compiler/cfg/rpo/rpo.factor
@@ -9,7 +9,10 @@ SYMBOL: visited
: post-order-traversal ( bb -- )
dup id>> visited get key? [ drop ] [
dup id>> visited get conjoin
- [ successors>> [ post-order-traversal ] each ] [ , ] bi
+ [
+ successors>> <reversed>
+ [ post-order-traversal ] each
+ ] [ , ] bi
] if ;
: post-order ( bb -- blocks )
From 6590c894bc94186e6b507ff02b693804bff3d92d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 13 Nov 2008 04:10:21 -0600
Subject: [PATCH 051/157] Forgot a constant
---
basis/compiler/constants/constants.factor | 17 +++++++++--------
1 file changed, 9 insertions(+), 8 deletions(-)
diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor
index cd68602768..86c1f65049 100644
--- a/basis/compiler/constants/constants.factor
+++ b/basis/compiler/constants/constants.factor
@@ -37,14 +37,15 @@ IN: compiler.constants
: rc-indirect-arm-pc 8 ; inline
! Relocation types
-: rt-primitive 0 ; inline
-: rt-dlsym 1 ; inline
-: rt-literal 2 ; inline
-: rt-dispatch 3 ; inline
-: rt-xt 4 ; inline
-: rt-here 5 ; inline
-: rt-label 6 ; inline
-: rt-immediate 7 ; inline
+: rt-primitive 0 ; inline
+: rt-dlsym 1 ; inline
+: rt-literal 2 ; inline
+: rt-dispatch 3 ; inline
+: rt-xt 4 ; inline
+: rt-here 5 ; inline
+: rt-label 6 ; inline
+: rt-immediate 7 ; inline
+: rt-stack-chain 8 ; inline
: rc-absolute? ( n -- ? )
[ rc-absolute-ppc-2/2 = ]
From 029ee6752570a23edaa7a2844aa5951fdea193b8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 13 Nov 2008 04:12:09 -0600
Subject: [PATCH 052/157] Fix ppc make-image
---
basis/cpu/ppc/bootstrap.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor
index 8809311f21..aee0f3f4f3 100644
--- a/basis/cpu/ppc/bootstrap.factor
+++ b/basis/cpu/ppc/bootstrap.factor
@@ -59,7 +59,7 @@ big-endian on
0 6 LOAD32
7 6 0 LWZ
1 7 0 STW
-] rc-absolute-ppc-2/2 rt-primitive 1 jit-save-stack jit-define
+] rc-absolute-ppc-2/2 rt-stack-chain 1 jit-save-stack jit-define
[
0 6 LOAD32
From eb05dd3a12e04fabdd40da654cd06590b7172cec Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 13 Nov 2008 04:16:08 -0600
Subject: [PATCH 053/157] Optimize a ##dispatch that is applied to the result
of a ##sub-imm or ##add-imm; this eliminates an instruction from the common 1
fixnum-fast { ... } dispatch and 8 fixnum-fast { ... } dispatch code
sequences appearing in generic word expansions
---
basis/compiler/cfg/builder/builder.factor | 2 +-
.../cfg/instructions/instructions.factor | 2 +-
.../cfg/value-numbering/rewrite/rewrite.factor | 16 +++++++++++++++-
.../value-numbering/value-numbering-tests.factor | 2 +-
basis/compiler/codegen/codegen.factor | 2 +-
basis/compiler/codegen/fixup/fixup.factor | 4 ++--
basis/cpu/architecture/architecture.factor | 2 +-
basis/cpu/ppc/ppc.factor | 4 ++--
basis/cpu/x86/32/32.factor | 14 +++++++++++++-
basis/cpu/x86/64/64.factor | 15 ++++++++++++++-
basis/cpu/x86/x86.factor | 13 -------------
11 files changed, 51 insertions(+), 25 deletions(-)
diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 77ed04f4b3..7bad44f7a6 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -190,7 +190,7 @@ M: #if emit-node
: emit-dispatch ( node -- )
##epilogue
- ds-pop ^^offset>slot i ##dispatch
+ ds-pop ^^offset>slot i 0 ##dispatch
dispatch-branches ;
: <dispatch-block> ( -- word )
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index c39f517671..b2c752e612 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -62,7 +62,7 @@ INSN: ##jump word ;
INSN: ##return ;
! Jump tables
-INSN: ##dispatch src temp ;
+INSN: ##dispatch src temp offset ;
INSN: ##dispatch-label label ;
! Slot access
diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
index 94c3f0d6f9..5f67f8097e 100644
--- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
+++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences layouts accessors combinators namespaces
-math
+math fry
compiler.cfg.instructions
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.simplify
@@ -113,4 +113,18 @@ M: ##compare-imm rewrite
] when
] when ;
+: dispatch-offset ( expr -- n )
+ [ in2>> vn>constant tag-bits get neg shift ] [ op>> ] bi
+ \ ##sub-imm eq? [ neg ] when ;
+
+: add-dispatch-offset? ( insn -- expr ? )
+ src>> vreg>expr dup op>> { ##add-imm ##sub-imm } memq? ; inline
+
+M: ##dispatch rewrite
+ dup add-dispatch-offset? [
+ [ clone ] dip
+ [ in1>> vn>vreg >>src ]
+ [ dispatch-offset '[ _ + ] change-offset ] bi
+ ] [ drop ] if ;
+
M: insn rewrite ;
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index d3be68c3c9..b73736ed14 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -34,7 +34,7 @@ compiler.cfg.registers cpu.architecture tools.test kernel math ;
[ t ] [
{
T{ ##peek f V int-regs 1 D 0 }
- T{ ##dispatch f V int-regs 1 V int-regs 2 }
+ T{ ##dispatch f V int-regs 1 V int-regs 2 0 }
} dup value-numbering =
] unit-test
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 35d4d59253..0d45b28126 100644
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -93,7 +93,7 @@ M: ##return generate-insn drop %return ;
M: ##dispatch-label generate-insn label>> %dispatch-label ;
M: ##dispatch generate-insn
- [ src>> register ] [ temp>> register ] bi %dispatch ;
+ [ src>> register ] [ temp>> register ] [ offset>> ] tri %dispatch ;
: >slot<
{
diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor
index fe270f4410..b25f1fa8fe 100755
--- a/basis/compiler/codegen/fixup/fixup.factor
+++ b/basis/compiler/codegen/fixup/fixup.factor
@@ -72,8 +72,8 @@ SYMBOL: literal-table
: rel-this ( class -- )
0 swap rt-label rel-fixup ;
-: rel-here ( class -- )
- 0 swap rt-here rel-fixup ;
+: rel-here ( offset class -- )
+ rt-here rel-fixup ;
: init-fixup ( -- )
BV{ } clone relocation-table set
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index b0b5b048d9..96dd577c10 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -50,7 +50,7 @@ HOOK: %call cpu ( word -- )
HOOK: %jump-label cpu ( label -- )
HOOK: %return cpu ( -- )
-HOOK: %dispatch cpu ( src temp -- )
+HOOK: %dispatch cpu ( src temp offset -- )
HOOK: %dispatch-label cpu ( word -- )
HOOK: %slot cpu ( dst obj slot tag temp -- )
diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index 49caae4bb8..1bc8d6975d 100644
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -111,10 +111,10 @@ M: ppc %call ( label -- ) BL ;
M: ppc %jump-label ( label -- ) B ;
M: ppc %return ( -- ) BLR ;
-M:: ppc %dispatch ( src temp -- )
+M:: ppc %dispatch ( src temp offset -- )
0 temp LOAD32 rc-absolute-ppc-2/2 rel-here
temp temp src ADD
- temp temp 5 cells LWZ
+ temp temp 5 offset + cells LWZ
temp MTCTR
BCTR ;
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index f26d76551a..f892271fd5 100644
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -6,7 +6,7 @@ accessors init combinators command-line cpu.x86.assembler
cpu.x86 cpu.architecture compiler compiler.units
compiler.constants compiler.alien compiler.codegen
compiler.codegen.fixup compiler.cfg.instructions
-compiler.cfg.builder compiler.cfg.intrinsics ;
+compiler.cfg.builder compiler.cfg.intrinsics make ;
IN: cpu.x86.32
! We implement the FFI for Linux, OS X and Windows all at once.
@@ -26,6 +26,18 @@ M: x86.32 stack-reg ESP ;
M: x86.32 temp-reg-1 EAX ;
M: x86.32 temp-reg-2 ECX ;
+M:: x86.32 %dispatch ( src temp offset -- )
+ ! Load jump table base.
+ src HEX: ffffffff ADD
+ offset cells rc-absolute-cell rel-here
+ ! Go
+ src HEX: 7f [+] JMP
+ ! Fix up the displacement above
+ cell code-alignment
+ [ 7 + building get dup pop* push ]
+ [ align-code ]
+ bi ;
+
M: x86.32 reserved-area-size 0 ;
M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index 0d20660021..75c808b50a 100644
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel math namespaces make sequences
system layouts alien alien.c-types alien.accessors alien.structs
-slots splitting assocs combinators cpu.x86.assembler
+slots splitting assocs combinators make locals cpu.x86.assembler
cpu.x86 cpu.architecture compiler.constants
compiler.codegen compiler.codegen.fixup
compiler.cfg.instructions compiler.cfg.builder
@@ -24,6 +24,19 @@ M: x86.64 stack-reg RSP ;
M: x86.64 temp-reg-1 RAX ;
M: x86.64 temp-reg-2 RCX ;
+M:: x86.64 %dispatch ( src temp offset -- )
+ ! Load jump table base.
+ temp HEX: ffffffff MOV
+ offset cells rc-absolute-cell rel-here
+ ! Add jump table base
+ src temp ADD
+ src HEX: 7f [+] JMP
+ ! Fix up the displacement above
+ cell code-alignment
+ [ 15 + building get dup pop* push ]
+ [ align-code ]
+ bi ;
+
: param-reg-1 int-regs param-regs first ; inline
: param-reg-2 int-regs param-regs second ; inline
: param-reg-3 int-regs param-regs third ; inline
diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index 4f72fe45e1..dfe3d3e55e 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -60,19 +60,6 @@ M: x86 %return ( -- ) 0 RET ;
: align-code ( n -- )
0 <repetition> % ;
-M:: x86 %dispatch ( src temp -- )
- ! Load jump table base. We use a temporary register
- ! since on AMD64 we have to load a 64-bit immediate. On
- ! x86, this is redundant.
- ! Add jump table base
- temp HEX: ffffffff MOV rc-absolute-cell rel-here
- src temp ADD
- src HEX: 7f [+] JMP
- ! Fix up the displacement above
- cell code-alignment dup bootstrap-cell 8 = 15 9 ? +
- building get dup pop* push
- align-code ;
-
M: x86 %dispatch-label ( word -- )
0 cell, rc-absolute-cell rel-word ;
From 5b4e8e9d097d5d36feefdf8428961202deeda27b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 13 Nov 2008 04:16:58 -0600
Subject: [PATCH 054/157] Rename tests/templates.factor to tests/codegen.factor
since that's really what its testing
---
.../tests/{templates.factor => codegen.factor} | 11 +++++++++++
1 file changed, 11 insertions(+)
rename basis/compiler/tests/{templates.factor => codegen.factor} (95%)
diff --git a/basis/compiler/tests/templates.factor b/basis/compiler/tests/codegen.factor
similarity index 95%
rename from basis/compiler/tests/templates.factor
rename to basis/compiler/tests/codegen.factor
index 0a109a15eb..a56ee55c82 100644
--- a/basis/compiler/tests/templates.factor
+++ b/basis/compiler/tests/codegen.factor
@@ -230,3 +230,14 @@ TUPLE: id obj ;
10000000 [ "hi" 0 (gc-check-bug) drop ] times ;
[ ] [ gc-check-bug ] unit-test
+
+! New optimization
+: test-1 ( a -- b ) 8 fixnum-fast { [ "a" ] [ "b" ] } dispatch ;
+
+[ "a" ] [ 8 test-1 ] unit-test
+[ "b" ] [ 9 test-1 ] unit-test
+
+: test-2 ( a -- b ) 1 fixnum-fast { [ "a" ] [ "b" ] } dispatch ;
+
+[ "a" ] [ 1 test-2 ] unit-test
+[ "b" ] [ 2 test-2 ] unit-test
From a14e1ebcb5a78e0a90ebdd12eee4b5fe5b799668 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 13 Nov 2008 05:55:34 -0600
Subject: [PATCH 055/157] Fix PowerPC bootstrap
---
basis/cpu/ppc/ppc.factor | 5 +++--
1 file changed, 3 insertions(+), 2 deletions(-)
diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index 1bc8d6975d..2ff9921abf 100644
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -112,9 +112,10 @@ M: ppc %jump-label ( label -- ) B ;
M: ppc %return ( -- ) BLR ;
M:: ppc %dispatch ( src temp offset -- )
- 0 temp LOAD32 rc-absolute-ppc-2/2 rel-here
+ 0 temp LOAD32
+ 5 offset + cells rc-absolute-ppc-2/2 rel-here
temp temp src ADD
- temp temp 5 offset + cells LWZ
+ temp temp 0 LWZ
temp MTCTR
BCTR ;
From eef45a1cc3a66b22ddb09b9bb4288b7ec4e74bec Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 13 Nov 2008 05:58:49 -0600
Subject: [PATCH 056/157] Tweak PowerPC %dispatch
---
basis/cpu/ppc/ppc.factor | 5 ++---
1 file changed, 2 insertions(+), 3 deletions(-)
diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index 2ff9921abf..c656ae4d89 100644
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -113,9 +113,8 @@ M: ppc %return ( -- ) BLR ;
M:: ppc %dispatch ( src temp offset -- )
0 temp LOAD32
- 5 offset + cells rc-absolute-ppc-2/2 rel-here
- temp temp src ADD
- temp temp 0 LWZ
+ 4 offset + cells rc-absolute-ppc-2/2 rel-here
+ temp temp src LWZX
temp MTCTR
BCTR ;
From 4858a2ea74ed710adbf2bd002db6e6d5813a2611 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 13 Nov 2008 09:33:18 -0600
Subject: [PATCH 057/157] Simplify inline? now that generic words can't be
inline anymore
---
core/generic/generic.factor | 3 ---
core/generic/standard/engines/tuple/tuple.factor | 3 ---
core/words/words.factor | 4 +---
3 files changed, 1 insertion(+), 9 deletions(-)
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index cb5f9f3791..e2818a51b2 100644
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -76,9 +76,6 @@ TUPLE: check-method class generic ;
PREDICATE: method-body < word
"method-generic" word-prop >boolean ;
-M: method-body inline?
- "method-generic" word-prop inline? ;
-
M: method-body stack-effect
"method-generic" word-prop stack-effect ;
diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor
index 04368099fb..78a97547fd 100644
--- a/core/generic/standard/engines/tuple/tuple.factor
+++ b/core/generic/standard/engines/tuple/tuple.factor
@@ -79,9 +79,6 @@ M: engine-word stack-effect
[ extra-values ] [ stack-effect ] bi
dup [ clone [ length + ] change-in ] [ 2drop f ] if ;
-M: engine-word inline?
- "tuple-dispatch-generic" word-prop inline? ;
-
M: engine-word crossref? "forgotten" word-prop not ;
M: engine-word irrelevant? drop t ;
diff --git a/core/words/words.factor b/core/words/words.factor
index 8a4f7e7bd2..66c60dc06e 100644
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -135,9 +135,7 @@ compiled-generic-crossref global [ H{ } assoc-like ] change-at
[ compiled-generic-crossref get delete-at ]
tri ;
-GENERIC: inline? ( word -- ? )
-
-M: word inline? "inline" word-prop ;
+: inline? ( word -- ? ) "inline" word-prop ; inline
SYMBOL: visited
From 1498d94a53f4910a557c832be9c1ce3ab171f61d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 13 Nov 2008 09:34:46 -0600
Subject: [PATCH 058/157] Move suffix arrays to basis
---
{extra => basis}/suffix-arrays/authors.txt | 0
{extra => basis}/suffix-arrays/suffix-arrays-docs.factor | 0
{extra => basis}/suffix-arrays/suffix-arrays-tests.factor | 0
{extra => basis}/suffix-arrays/suffix-arrays.factor | 0
{extra => basis}/suffix-arrays/summary.txt | 0
{extra => basis}/suffix-arrays/tags.txt | 0
{extra => basis}/suffix-arrays/words/words.factor | 0
7 files changed, 0 insertions(+), 0 deletions(-)
rename {extra => basis}/suffix-arrays/authors.txt (100%)
rename {extra => basis}/suffix-arrays/suffix-arrays-docs.factor (100%)
rename {extra => basis}/suffix-arrays/suffix-arrays-tests.factor (100%)
rename {extra => basis}/suffix-arrays/suffix-arrays.factor (100%)
rename {extra => basis}/suffix-arrays/summary.txt (100%)
rename {extra => basis}/suffix-arrays/tags.txt (100%)
rename {extra => basis}/suffix-arrays/words/words.factor (100%)
diff --git a/extra/suffix-arrays/authors.txt b/basis/suffix-arrays/authors.txt
similarity index 100%
rename from extra/suffix-arrays/authors.txt
rename to basis/suffix-arrays/authors.txt
diff --git a/extra/suffix-arrays/suffix-arrays-docs.factor b/basis/suffix-arrays/suffix-arrays-docs.factor
similarity index 100%
rename from extra/suffix-arrays/suffix-arrays-docs.factor
rename to basis/suffix-arrays/suffix-arrays-docs.factor
diff --git a/extra/suffix-arrays/suffix-arrays-tests.factor b/basis/suffix-arrays/suffix-arrays-tests.factor
similarity index 100%
rename from extra/suffix-arrays/suffix-arrays-tests.factor
rename to basis/suffix-arrays/suffix-arrays-tests.factor
diff --git a/extra/suffix-arrays/suffix-arrays.factor b/basis/suffix-arrays/suffix-arrays.factor
similarity index 100%
rename from extra/suffix-arrays/suffix-arrays.factor
rename to basis/suffix-arrays/suffix-arrays.factor
diff --git a/extra/suffix-arrays/summary.txt b/basis/suffix-arrays/summary.txt
similarity index 100%
rename from extra/suffix-arrays/summary.txt
rename to basis/suffix-arrays/summary.txt
diff --git a/extra/suffix-arrays/tags.txt b/basis/suffix-arrays/tags.txt
similarity index 100%
rename from extra/suffix-arrays/tags.txt
rename to basis/suffix-arrays/tags.txt
diff --git a/extra/suffix-arrays/words/words.factor b/basis/suffix-arrays/words/words.factor
similarity index 100%
rename from extra/suffix-arrays/words/words.factor
rename to basis/suffix-arrays/words/words.factor
From 6d44e383b358ea56f20ac2c0d8099e461c8972b3 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Thu, 13 Nov 2008 14:27:28 -0600
Subject: [PATCH 059/157] add rc files to scaffold since it's hard to create a
file named .foo on windows
---
basis/tools/scaffold/scaffold.factor | 9 +++++++++
1 file changed, 9 insertions(+)
diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor
index e1076775fa..2811801266 100644
--- a/basis/tools/scaffold/scaffold.factor
+++ b/basis/tools/scaffold/scaffold.factor
@@ -263,3 +263,12 @@ SYMBOL: examples-flag
[ example ] times
"}" print
] with-variable ;
+
+: scaffold-rc ( path -- )
+ [ touch-file ] [ "Click to edit: " write <pathname> . ] bi ;
+
+: scaffold-factor-boot-rc ( -- )
+ home ".factor-boot-rc" append-path scaffold-rc ;
+
+: scaffold-factor-rc ( -- )
+ home ".factor-rc" append-path scaffold-rc ;
From 069d5b17959bec9b615b28155741659fc9f1fa3c Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Thu, 13 Nov 2008 15:47:39 -0600
Subject: [PATCH 060/157] add etexteditor
---
basis/editors/etexteditor/authors.txt | 1 +
basis/editors/etexteditor/etexteditor.factor | 18 ++++++++++++++++++
basis/editors/etexteditor/summary.txt | 1 +
basis/editors/etexteditor/tags.txt | 1 +
4 files changed, 21 insertions(+)
create mode 100755 basis/editors/etexteditor/authors.txt
create mode 100755 basis/editors/etexteditor/etexteditor.factor
create mode 100755 basis/editors/etexteditor/summary.txt
create mode 100755 basis/editors/etexteditor/tags.txt
diff --git a/basis/editors/etexteditor/authors.txt b/basis/editors/etexteditor/authors.txt
new file mode 100755
index 0000000000..7b1e3b7fa0
--- /dev/null
+++ b/basis/editors/etexteditor/authors.txt
@@ -0,0 +1 @@
+Kibleur Christophe
\ No newline at end of file
diff --git a/basis/editors/etexteditor/etexteditor.factor b/basis/editors/etexteditor/etexteditor.factor
new file mode 100755
index 0000000000..1ce1004535
--- /dev/null
+++ b/basis/editors/etexteditor/etexteditor.factor
@@ -0,0 +1,18 @@
+! Copyright (C) 2008 Kibleur Christophe.
+! See http://factorcode.org/license.txt for BSD license.
+USING: editors io.files io.launcher kernel math.parser
+namespaces sequences windows.shell32 make ;
+IN: editors.etexteditor
+
+: etexteditor-path ( -- str )
+ \ etexteditor-path get-global [
+ program-files "e\\e.exe" append-path
+ ] unless* ;
+
+: etexteditor ( file line -- )
+ [
+ etexteditor-path ,
+ "-n" swap number>string append , ,
+ ] { } make run-detached drop ;
+
+[ etexteditor ] edit-hook set-global
diff --git a/basis/editors/etexteditor/summary.txt b/basis/editors/etexteditor/summary.txt
new file mode 100755
index 0000000000..46537003d9
--- /dev/null
+++ b/basis/editors/etexteditor/summary.txt
@@ -0,0 +1 @@
+etexteditor integration
diff --git a/basis/editors/etexteditor/tags.txt b/basis/editors/etexteditor/tags.txt
new file mode 100755
index 0000000000..6bf68304bb
--- /dev/null
+++ b/basis/editors/etexteditor/tags.txt
@@ -0,0 +1 @@
+unportable
From 8a25012b5500ecf10fb2f12b829227cdbfec375e Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 13 Nov 2008 16:07:01 -0600
Subject: [PATCH 061/157] fix line numbers with etexteditor
---
basis/editors/etexteditor/etexteditor.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/editors/etexteditor/etexteditor.factor b/basis/editors/etexteditor/etexteditor.factor
index 1ce1004535..38d3fde5b2 100755
--- a/basis/editors/etexteditor/etexteditor.factor
+++ b/basis/editors/etexteditor/etexteditor.factor
@@ -12,7 +12,7 @@ IN: editors.etexteditor
: etexteditor ( file line -- )
[
etexteditor-path ,
- "-n" swap number>string append , ,
- ] { } make run-detached drop ;
+ [ , ] [ "--line" , number>string , ] bi*
+ ] { } make USE: prettyprint dup . run-detached drop ;
[ etexteditor ] edit-hook set-global
From a5c47ac294b42ea7acec6083c921d5d203dd2016 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 13 Nov 2008 16:09:03 -0600
Subject: [PATCH 062/157] remove debug, add -a option
---
basis/editors/etexteditor/etexteditor.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/editors/etexteditor/etexteditor.factor b/basis/editors/etexteditor/etexteditor.factor
index 38d3fde5b2..e6b85494ee 100755
--- a/basis/editors/etexteditor/etexteditor.factor
+++ b/basis/editors/etexteditor/etexteditor.factor
@@ -11,8 +11,8 @@ IN: editors.etexteditor
: etexteditor ( file line -- )
[
- etexteditor-path ,
+ etexteditor-path , "-a" ,
[ , ] [ "--line" , number>string , ] bi*
- ] { } make USE: prettyprint dup . run-detached drop ;
+ ] { } make run-detached drop ;
[ etexteditor ] edit-hook set-global
From 8f2d1353c013de4409838ef5449dc843045d263a Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 13 Nov 2008 16:10:43 -0600
Subject: [PATCH 063/157] remove -a option...
---
basis/editors/etexteditor/etexteditor.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/editors/etexteditor/etexteditor.factor b/basis/editors/etexteditor/etexteditor.factor
index e6b85494ee..316bd24cfa 100755
--- a/basis/editors/etexteditor/etexteditor.factor
+++ b/basis/editors/etexteditor/etexteditor.factor
@@ -11,7 +11,7 @@ IN: editors.etexteditor
: etexteditor ( file line -- )
[
- etexteditor-path , "-a" ,
+ etexteditor-path ,
[ , ] [ "--line" , number>string , ] bi*
] { } make run-detached drop ;
From afc071eaf8d6195d2154a27b42b9740bbbb3a89a Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Thu, 13 Nov 2008 16:15:57 -0600
Subject: [PATCH 064/157] fix docs
---
basis/stack-checker/stack-checker-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor
index a9df463703..f208178b10 100644
--- a/basis/stack-checker/stack-checker-docs.factor
+++ b/basis/stack-checker/stack-checker-docs.factor
@@ -27,7 +27,7 @@ ARTICLE: "inference-combinators" "Combinator stack effects"
"Consider a combinator such as " { $link keep } ". The combinator itself does not have a stack effect, because it applies " { $link call } " to a potentially arbitrary quotation. However, since the combinator is declared " { $link POSTPONE: inline } ", a given usage of it can have a stack effect:"
{ $example "[ [ 2 + ] keep ] infer." "( object -- object object )" }
"Another example is the " { $link compose } " combinator. Because it is decared " { $link POSTPONE: inline } ", we can infer the stack effect of applying " { $link call } " to the result of " { $link compose } ":"
-{ $example "[ 2 [ + ] curry [ sq ] compose ] infer." "( -- object object )" }
+{ $example "[ 2 [ + ] curry [ sq ] compose ] infer." "( -- object )" }
"Incidentally, this example demonstrates that the stack effect of nested currying and composition can also be inferred."
$nl
"A general rule of thumb is that any word which applies " { $link call } " or " { $link curry } " to one of its inputs must be declared " { $link POSTPONE: inline } "."
From 4e0dee6280c4d411d4810750559c850ff64d2c8d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 13 Nov 2008 18:26:09 -0600
Subject: [PATCH 065/157] validators can use new regexps now
---
basis/validators/validators.factor | 5 ++---
1 file changed, 2 insertions(+), 3 deletions(-)
diff --git a/basis/validators/validators.factor b/basis/validators/validators.factor
index 30e1eadc7a..0ddced63e8 100644
--- a/basis/validators/validators.factor
+++ b/basis/validators/validators.factor
@@ -1,9 +1,8 @@
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations sequences math namespaces make sets
-math.parser math.ranges assocs parser-combinators.regexp
-unicode.categories arrays hashtables words classes quotations
-xmode.catalog ;
+math.parser math.ranges assocs regexp unicode.categories arrays
+hashtables words classes quotations xmode.catalog ;
IN: validators
: v-default ( str def -- str/def )
From 89a595703351646212b406c6ff7c57b9bb821eb0 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Thu, 13 Nov 2008 19:32:34 -0600
Subject: [PATCH 066/157] add file-type>ch and ch>file-type
---
basis/io/unix/files/files.factor | 24 ++++++++++++++++++++++++
1 file changed, 24 insertions(+)
diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor
index 9ebfdaaa5a..3f254e7713 100644
--- a/basis/io/unix/files/files.factor
+++ b/basis/io/unix/files/files.factor
@@ -172,6 +172,30 @@ M: unix (directory-entries) ( path -- seq )
PRIVATE>
+: ch>file-type ( ch -- type )
+ {
+ { CHAR: b [ +block-device+ ] }
+ { CHAR: c [ +character-device+ ] }
+ { CHAR: d [ +directory+ ] }
+ { CHAR: l [ +symbolic-link+ ] }
+ { CHAR: s [ +socket+ ] }
+ { CHAR: p [ +fifo+ ] }
+ { CHAR: - [ +regular-file+ ] }
+ [ drop +unknown+ ]
+ } case ;
+
+: file-type>ch ( type -- string )
+ {
+ { +block-device+ [ CHAR: b ] }
+ { +character-device+ [ CHAR: c ] }
+ { +directory+ [ CHAR: d ] }
+ { +symbolic-link+ [ CHAR: l ] }
+ { +socket+ [ CHAR: s ] }
+ { +fifo+ [ CHAR: p ] }
+ { +regular-file+ [ CHAR: - ] }
+ [ drop CHAR: - ]
+ } case ;
+
: UID OCT: 0004000 ; inline
: GID OCT: 0002000 ; inline
: STICKY OCT: 0001000 ; inline
From 617a4337068f9d8eb0a8efc8abdd4ac0de5539c1 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Thu, 13 Nov 2008 19:33:29 -0600
Subject: [PATCH 067/157] make a variable to set the ftp serving directory. fix
changing directories so you can't escape the serving directory. requires ls
vocab now
---
extra/ftp/client/client.factor | 2 +-
extra/ftp/ftp.factor | 32 ++------------------------------
extra/ftp/server/server.factor | 20 ++++++++++++++++----
3 files changed, 19 insertions(+), 35 deletions(-)
diff --git a/extra/ftp/client/client.factor b/extra/ftp/client/client.factor
index 8413331c00..9251e1aa55 100644
--- a/extra/ftp/client/client.factor
+++ b/extra/ftp/client/client.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays classes.singleton combinators
continuations io io.encodings.binary io.encodings.utf8
-io.files io.sockets kernel io.streams.duplex math
+io.files io.sockets kernel io.streams.duplex math ls
math.parser sequences splitting namespaces strings fry ftp ;
IN: ftp.client
diff --git a/extra/ftp/ftp.factor b/extra/ftp/ftp.factor
index 8f0b48bd4d..e396e36180 100644
--- a/extra/ftp/ftp.factor
+++ b/extra/ftp/ftp.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators io io.files kernel
-math.parser sequences strings ;
+math.parser sequences strings ls ;
IN: ftp
SINGLETON: active
@@ -32,35 +32,7 @@ TUPLE: ftp-response n strings parsed ;
over strings>> push ;
: ftp-send ( string -- ) write "\r\n" write flush ;
-
: ftp-ipv4 1 ; inline
: ftp-ipv6 2 ; inline
-: ch>type ( ch -- type )
- {
- { CHAR: d [ +directory+ ] }
- { CHAR: l [ +symbolic-link+ ] }
- { CHAR: - [ +regular-file+ ] }
- [ drop +unknown+ ]
- } case ;
-
-: type>ch ( type -- string )
- {
- { +directory+ [ CHAR: d ] }
- { +symbolic-link+ [ CHAR: l ] }
- { +regular-file+ [ CHAR: - ] }
- [ drop CHAR: - ]
- } case ;
-
-: file-info>string ( file-info name -- string )
- [
- [
- [ type>> type>ch 1string ]
- [ drop "rwx------" append ] bi
- ]
- [ size>> number>string 15 CHAR: \s pad-left ] bi
- ] dip 3array " " join ;
-
-: directory-list ( -- seq )
- "" directory-files
- [ [ link-info ] keep file-info>string ] map ;
+: directory-list ( -- seq ) "" ls ;
diff --git a/extra/ftp/server/server.factor b/extra/ftp/server/server.factor
index 170155bd43..969ec17224 100644
--- a/extra/ftp/server/server.factor
+++ b/extra/ftp/server/server.factor
@@ -6,12 +6,16 @@ io.encodings.utf8 io.files io.sockets kernel math.parser
namespaces make sequences ftp io.unix.launcher.parser
unicode.case splitting assocs classes io.servers.connection
destructors calendar io.timeouts io.streams.duplex threads
-continuations math concurrency.promises byte-arrays sequences.lib
-hexdump ;
+continuations math concurrency.promises byte-arrays
+io.backend sequences.lib hexdump ;
IN: ftp.server
SYMBOL: client
+: ftp-server-directory ( -- str )
+ \ ftp-server-directory get-global "resource:temp" or
+ normalize-path ;
+
TUPLE: ftp-command raw tokenized ;
: <ftp-command> ( -- obj )
@@ -238,10 +242,16 @@ M: ftp-put service-command ( stream obj -- )
! : handle-LPRT ( obj -- ) tokenized>> "," split ;
ERROR: not-a-directory ;
+ERROR: no-permissions ;
: handle-CWD ( obj -- )
[
- tokenized>> second dup directory? [
+ tokenized>> second dup normalize-path
+ dup ftp-server-directory head? [
+ no-permissions
+ ] unless
+
+ file-info directory? [
set-current-directory
250 "Directory successully changed." server-response
] [
@@ -256,6 +266,7 @@ ERROR: not-a-directory ;
: handle-client-loop ( -- )
<ftp-command> readln
+ USE: prettyprint global [ dup . flush ] bind
[ >>raw ]
[ tokenize-command >>tokenized ] bi
dup tokenized>> first >upper {
@@ -313,7 +324,7 @@ TUPLE: ftp-server < threaded-server ;
M: ftp-server handle-client* ( server -- )
drop
[
- "" [
+ ftp-server-directory [
host-name <ftp-client> client set
send-banner handle-client-loop
] with-directory
@@ -323,6 +334,7 @@ M: ftp-server handle-client* ( server -- )
ftp-server new-threaded-server
swap >>insecure
"ftp.server" >>name
+ 5 minutes >>timeout
latin1 >>encoding ;
: ftpd ( port -- )
From 294708cb797f4de6c0a37cbb872164186e1a9b8d Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Thu, 13 Nov 2008 19:39:40 -0600
Subject: [PATCH 068/157] ls works for unix, todo windows soon
---
extra/ls/authors.txt | 1 +
extra/ls/ls-tests.factor | 6 ++++
extra/ls/ls.factor | 63 ++++++++++++++++++++++++++++++++++++++++
extra/ls/tags.txt | 1 +
4 files changed, 71 insertions(+)
create mode 100644 extra/ls/authors.txt
create mode 100644 extra/ls/ls-tests.factor
create mode 100644 extra/ls/ls.factor
create mode 100644 extra/ls/tags.txt
diff --git a/extra/ls/authors.txt b/extra/ls/authors.txt
new file mode 100644
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/extra/ls/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/extra/ls/ls-tests.factor b/extra/ls/ls-tests.factor
new file mode 100644
index 0000000000..b1c1f18472
--- /dev/null
+++ b/extra/ls/ls-tests.factor
@@ -0,0 +1,6 @@
+! Copyright (C) 2008 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test ls strings kernel ;
+IN: ls.tests
+
+[ ] [ "" ls drop ] unit-test
diff --git a/extra/ls/ls.factor b/extra/ls/ls.factor
new file mode 100644
index 0000000000..3e21873fec
--- /dev/null
+++ b/extra/ls/ls.factor
@@ -0,0 +1,63 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators generalizations
+io.files io.unix.files math.parser sequences.lib calendar math
+kernel sequences unix.groups unix.users combinators.cleave
+strings combinators.short-circuit unicode.case ;
+IN: ls
+
+TUPLE: ls-info path user group size ;
+
+: ls-time ( timestamp -- string )
+ [ hour>> ] [ minute>> ] bi
+ [ number>string 2 CHAR: 0 pad-left ] bi@ ":" splice ;
+
+: ls-timestamp ( timestamp -- string )
+ [ month>> month-abbreviation ]
+ [ day>> number>string 2 CHAR: \s pad-left ]
+ [
+ dup year>> dup now year>> =
+ [ drop ls-time ] [ nip number>string ] if
+ 5 CHAR: \s pad-left
+ ] tri 3array " " join ;
+
+: read>string ( ? -- string ) "r" "-" ? ; inline
+
+: write>string ( ? -- string ) "w" "-" ? ; inline
+
+: execute-string ( str bools -- str' )
+ swap {
+ { { t t } [ >lower ] }
+ { { t f } [ >upper ] }
+ { { f t } [ drop "x" ] }
+ [ 2drop "-" ]
+ } case ;
+
+: permissions-string ( permissions -- str )
+ {
+ [ type>> file-type>ch 1string ]
+ [ user-read? read>string ]
+ [ user-write? write>string ]
+ [ [ uid? ] [ user-execute? ] bi 2array "s" execute-string ]
+ [ group-read? read>string ]
+ [ group-write? write>string ]
+ [ [ gid? ] [ group-execute? ] bi 2array "s" execute-string ]
+ [ other-read? read>string ]
+ [ other-write? write>string ]
+ [ [ sticky? ] [ other-execute? ] bi 2array "t" execute-string ]
+ } <arr> concat ;
+
+: ls ( path -- lines )
+ [ [ [
+ "" directory-files [
+ dup file-info
+ {
+ [ permissions-string ]
+ [ nlink>> number>string 3 CHAR: \s pad-left ]
+ ! [ uid>> ]
+ ! [ gid>> ]
+ [ size>> number>string 15 CHAR: \s pad-left ]
+ [ modified>> ls-timestamp ]
+ } <arr> swap suffix " " join
+ ] map
+ ] with-group-cache ] with-user-cache ] with-directory ;
diff --git a/extra/ls/tags.txt b/extra/ls/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/extra/ls/tags.txt
@@ -0,0 +1 @@
+unportable
From c613eca829aba268141c057de2b7d1c57e003297 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Thu, 13 Nov 2008 19:48:11 -0600
Subject: [PATCH 069/157] move hexdump to tools.hexdump
---
basis/tools/hexdump/authors.txt | 1 +
basis/tools/hexdump/hexdump-docs.factor | 22 +++++++++++++++
basis/tools/hexdump/hexdump-tests.factor | 11 ++++++++
basis/tools/hexdump/hexdump.factor | 36 ++++++++++++++++++++++++
basis/tools/hexdump/summary.txt | 1 +
5 files changed, 71 insertions(+)
create mode 100644 basis/tools/hexdump/authors.txt
create mode 100644 basis/tools/hexdump/hexdump-docs.factor
create mode 100644 basis/tools/hexdump/hexdump-tests.factor
create mode 100644 basis/tools/hexdump/hexdump.factor
create mode 100644 basis/tools/hexdump/summary.txt
diff --git a/basis/tools/hexdump/authors.txt b/basis/tools/hexdump/authors.txt
new file mode 100644
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/basis/tools/hexdump/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/basis/tools/hexdump/hexdump-docs.factor b/basis/tools/hexdump/hexdump-docs.factor
new file mode 100644
index 0000000000..4278e92f0e
--- /dev/null
+++ b/basis/tools/hexdump/hexdump-docs.factor
@@ -0,0 +1,22 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel sequences strings ;
+IN: hexdump
+
+HELP: hexdump.
+{ $values { "seq" sequence } }
+{ $description "Converts a sequence to its hexadecimal and ASCII representation sixteen characters at a time and writes it to standard out." } ;
+
+HELP: hexdump
+{ $values { "seq" sequence } { "str" string } }
+{ $description "Converts a sequence to its hexadecimal and ASCII representation sixteen characters at a time. Lines are separated by a newline character." }
+{ $see-also hexdump. } ;
+
+ARTICLE: "hexdump" "Hexdump"
+"The " { $vocab-link "hexdump" } " vocabulary provides a traditional hexdump view of a sequence." $nl
+"Write hexdump to string:"
+{ $subsection hexdump }
+"Write the hexdump to the output stream:"
+{ $subsection hexdump. } ;
+
+ABOUT: "hexdump"
diff --git a/basis/tools/hexdump/hexdump-tests.factor b/basis/tools/hexdump/hexdump-tests.factor
new file mode 100644
index 0000000000..b3c03196f5
--- /dev/null
+++ b/basis/tools/hexdump/hexdump-tests.factor
@@ -0,0 +1,11 @@
+IN: hexdump.tests
+USING: hexdump kernel sequences tools.test ;
+
+[ t ] [ "" hexdump "Length: 0, 0h\n" = ] unit-test
+[ t ] [ "abcdefghijklmnopqrstuvwxyz" hexdump "Length: 26, 1ah\n00000000h: 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f 70 abcdefghijklmnop\n00000010h: 71 72 73 74 75 76 77 78 79 7a qrstuvwxyz\n" = ] unit-test
+
+[ t ] [ 256 [ ] map hexdump "Length: 256, 100h\n00000000h: 00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f ................\n00000010h: 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f ................\n00000020h: 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f !\"#$%&'()*+,-./\n00000030h: 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 0123456789:;<=>?\n00000040h: 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f @ABCDEFGHIJKLMNO\n00000050h: 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f PQRSTUVWXYZ[\\]^_\n00000060h: 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f `abcdefghijklmno\n00000070h: 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f pqrstuvwxyz{|}~.\n00000080h: 80 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f ................\n00000090h: 90 91 92 93 94 95 96 97 98 99 9a 9b 9c 9d 9e 9f ................\n000000a0h: a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 aa ab ac ad ae af ................\n000000b0h: b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf ................\n000000c0h: c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf ................\n000000d0h: d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 da db dc dd de df ................\n000000e0h: e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 ea eb ec ed ee ef ................\n000000f0h: f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb fc fd fe ff ................\n" = ] unit-test
+
+
+[
+ "Length: 3, 3h\n00000000h: 01 02 03 ...\n" ] [ B{ 1 2 3 } hexdump ] unit-test
diff --git a/basis/tools/hexdump/hexdump.factor b/basis/tools/hexdump/hexdump.factor
new file mode 100644
index 0000000000..c8b9f4accc
--- /dev/null
+++ b/basis/tools/hexdump/hexdump.factor
@@ -0,0 +1,36 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays io io.streams.string kernel math math.parser
+namespaces sequences splitting grouping strings ascii ;
+IN: tools.hexdump
+
+<PRIVATE
+
+: write-header ( len -- )
+ "Length: " write
+ [ number>string write ", " write ]
+ [ >hex write "h" write nl ] bi ;
+
+: write-offset ( lineno -- )
+ 16 * >hex 8 CHAR: 0 pad-left write "h: " write ;
+
+: >hex-digit ( digit -- str )
+ >hex 2 CHAR: 0 pad-left " " append ;
+
+: >hex-digits ( bytes -- str )
+ [ >hex-digit ] { } map-as concat 48 CHAR: \s pad-right ;
+
+: >ascii ( bytes -- str )
+ [ [ printable? ] keep CHAR: . ? ] "" map-as ;
+
+: write-hex-line ( bytes lineno -- )
+ write-offset [ >hex-digits write ] [ >ascii write ] bi nl ;
+
+PRIVATE>
+
+: hexdump. ( seq -- )
+ [ length write-header ]
+ [ 16 <sliced-groups> [ write-hex-line ] each-index ] bi ;
+
+: hexdump ( seq -- str )
+ [ hexdump. ] with-string-writer ;
diff --git a/basis/tools/hexdump/summary.txt b/basis/tools/hexdump/summary.txt
new file mode 100644
index 0000000000..d860bd7f84
--- /dev/null
+++ b/basis/tools/hexdump/summary.txt
@@ -0,0 +1 @@
+Prints formatted hex dump of an arbitrary sequence
From 47124b8aaa11508d2b4ba8d97d0d353f268b8468 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Thu, 13 Nov 2008 19:49:34 -0600
Subject: [PATCH 070/157] finish moving hexdump to tools.hexdump
---
basis/tools/hexdump/hexdump-docs.factor | 2 +-
basis/tools/hexdump/hexdump-tests.factor | 2 +-
extra/ftp/server/server.factor | 2 +-
extra/hexdump/authors.txt | 1 -
extra/hexdump/hexdump-docs.factor | 22 ---------------
extra/hexdump/hexdump-tests.factor | 11 --------
extra/hexdump/hexdump.factor | 36 ------------------------
extra/hexdump/summary.txt | 1 -
extra/tar/tar.factor | 2 +-
9 files changed, 4 insertions(+), 75 deletions(-)
delete mode 100644 extra/hexdump/authors.txt
delete mode 100644 extra/hexdump/hexdump-docs.factor
delete mode 100644 extra/hexdump/hexdump-tests.factor
delete mode 100644 extra/hexdump/hexdump.factor
delete mode 100644 extra/hexdump/summary.txt
diff --git a/basis/tools/hexdump/hexdump-docs.factor b/basis/tools/hexdump/hexdump-docs.factor
index 4278e92f0e..b24cc8ae33 100644
--- a/basis/tools/hexdump/hexdump-docs.factor
+++ b/basis/tools/hexdump/hexdump-docs.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel sequences strings ;
-IN: hexdump
+IN: tools.hexdump
HELP: hexdump.
{ $values { "seq" sequence } }
diff --git a/basis/tools/hexdump/hexdump-tests.factor b/basis/tools/hexdump/hexdump-tests.factor
index b3c03196f5..1a638a8586 100644
--- a/basis/tools/hexdump/hexdump-tests.factor
+++ b/basis/tools/hexdump/hexdump-tests.factor
@@ -1,5 +1,5 @@
-IN: hexdump.tests
USING: hexdump kernel sequences tools.test ;
+IN: tools.hexdump.tests
[ t ] [ "" hexdump "Length: 0, 0h\n" = ] unit-test
[ t ] [ "abcdefghijklmnopqrstuvwxyz" hexdump "Length: 26, 1ah\n00000000h: 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f 70 abcdefghijklmnop\n00000010h: 71 72 73 74 75 76 77 78 79 7a qrstuvwxyz\n" = ] unit-test
diff --git a/extra/ftp/server/server.factor b/extra/ftp/server/server.factor
index 969ec17224..e40af2afbe 100644
--- a/extra/ftp/server/server.factor
+++ b/extra/ftp/server/server.factor
@@ -7,7 +7,7 @@ namespaces make sequences ftp io.unix.launcher.parser
unicode.case splitting assocs classes io.servers.connection
destructors calendar io.timeouts io.streams.duplex threads
continuations math concurrency.promises byte-arrays
-io.backend sequences.lib hexdump ;
+io.backend sequences.lib tools.hexdump ;
IN: ftp.server
SYMBOL: client
diff --git a/extra/hexdump/authors.txt b/extra/hexdump/authors.txt
deleted file mode 100644
index 7c1b2f2279..0000000000
--- a/extra/hexdump/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Doug Coleman
diff --git a/extra/hexdump/hexdump-docs.factor b/extra/hexdump/hexdump-docs.factor
deleted file mode 100644
index 4278e92f0e..0000000000
--- a/extra/hexdump/hexdump-docs.factor
+++ /dev/null
@@ -1,22 +0,0 @@
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel sequences strings ;
-IN: hexdump
-
-HELP: hexdump.
-{ $values { "seq" sequence } }
-{ $description "Converts a sequence to its hexadecimal and ASCII representation sixteen characters at a time and writes it to standard out." } ;
-
-HELP: hexdump
-{ $values { "seq" sequence } { "str" string } }
-{ $description "Converts a sequence to its hexadecimal and ASCII representation sixteen characters at a time. Lines are separated by a newline character." }
-{ $see-also hexdump. } ;
-
-ARTICLE: "hexdump" "Hexdump"
-"The " { $vocab-link "hexdump" } " vocabulary provides a traditional hexdump view of a sequence." $nl
-"Write hexdump to string:"
-{ $subsection hexdump }
-"Write the hexdump to the output stream:"
-{ $subsection hexdump. } ;
-
-ABOUT: "hexdump"
diff --git a/extra/hexdump/hexdump-tests.factor b/extra/hexdump/hexdump-tests.factor
deleted file mode 100644
index b3c03196f5..0000000000
--- a/extra/hexdump/hexdump-tests.factor
+++ /dev/null
@@ -1,11 +0,0 @@
-IN: hexdump.tests
-USING: hexdump kernel sequences tools.test ;
-
-[ t ] [ "" hexdump "Length: 0, 0h\n" = ] unit-test
-[ t ] [ "abcdefghijklmnopqrstuvwxyz" hexdump "Length: 26, 1ah\n00000000h: 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f 70 abcdefghijklmnop\n00000010h: 71 72 73 74 75 76 77 78 79 7a qrstuvwxyz\n" = ] unit-test
-
-[ t ] [ 256 [ ] map hexdump "Length: 256, 100h\n00000000h: 00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f ................\n00000010h: 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f ................\n00000020h: 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f !\"#$%&'()*+,-./\n00000030h: 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 0123456789:;<=>?\n00000040h: 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f @ABCDEFGHIJKLMNO\n00000050h: 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f PQRSTUVWXYZ[\\]^_\n00000060h: 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f `abcdefghijklmno\n00000070h: 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f pqrstuvwxyz{|}~.\n00000080h: 80 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f ................\n00000090h: 90 91 92 93 94 95 96 97 98 99 9a 9b 9c 9d 9e 9f ................\n000000a0h: a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 aa ab ac ad ae af ................\n000000b0h: b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf ................\n000000c0h: c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf ................\n000000d0h: d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 da db dc dd de df ................\n000000e0h: e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 ea eb ec ed ee ef ................\n000000f0h: f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb fc fd fe ff ................\n" = ] unit-test
-
-
-[
- "Length: 3, 3h\n00000000h: 01 02 03 ...\n" ] [ B{ 1 2 3 } hexdump ] unit-test
diff --git a/extra/hexdump/hexdump.factor b/extra/hexdump/hexdump.factor
deleted file mode 100644
index ecbc2d6169..0000000000
--- a/extra/hexdump/hexdump.factor
+++ /dev/null
@@ -1,36 +0,0 @@
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays io io.streams.string kernel math math.parser
-namespaces sequences splitting grouping strings ascii ;
-IN: hexdump
-
-<PRIVATE
-
-: write-header ( len -- )
- "Length: " write
- [ number>string write ", " write ]
- [ >hex write "h" write nl ] bi ;
-
-: write-offset ( lineno -- )
- 16 * >hex 8 CHAR: 0 pad-left write "h: " write ;
-
-: >hex-digit ( digit -- str )
- >hex 2 CHAR: 0 pad-left " " append ;
-
-: >hex-digits ( bytes -- str )
- [ >hex-digit ] { } map-as concat 48 CHAR: \s pad-right ;
-
-: >ascii ( bytes -- str )
- [ [ printable? ] keep CHAR: . ? ] "" map-as ;
-
-: write-hex-line ( bytes lineno -- )
- write-offset [ >hex-digits write ] [ >ascii write ] bi nl ;
-
-PRIVATE>
-
-: hexdump. ( seq -- )
- [ length write-header ]
- [ 16 <sliced-groups> [ write-hex-line ] each-index ] bi ;
-
-: hexdump ( seq -- str )
- [ hexdump. ] with-string-writer ;
diff --git a/extra/hexdump/summary.txt b/extra/hexdump/summary.txt
deleted file mode 100644
index d860bd7f84..0000000000
--- a/extra/hexdump/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Prints formatted hex dump of an arbitrary sequence
diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor
index 286ac0183a..e3c14854d3 100755
--- a/extra/tar/tar.factor
+++ b/extra/tar/tar.factor
@@ -1,6 +1,6 @@
USING: combinators io io.files io.streams.string kernel math
math.parser continuations namespaces pack prettyprint sequences
-strings system hexdump io.encodings.binary summary accessors
+strings system tools.hexdump io.encodings.binary summary accessors
io.backend symbols byte-arrays ;
IN: tar
From a13c6a46557a0284c0a0a41652d96f2e2577f0bf Mon Sep 17 00:00:00 2001
From: jao <jao@oblong.net>
Date: Fri, 14 Nov 2008 02:54:37 +0100
Subject: [PATCH 071/157] - Bug fix: comments are fontified even when they
contain double quotes - Enhancement: more parsing words highlighted
---
misc/factor.el | 41 +++++++++++++++++++++++++----------------
1 file changed, 25 insertions(+), 16 deletions(-)
diff --git a/misc/factor.el b/misc/factor.el
index 1ae8919559..72fdf64159 100644
--- a/misc/factor.el
+++ b/misc/factor.el
@@ -19,9 +19,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; BUG: A double quote character on a commented line will break the
-;; syntax highlighting for that line.
-
(defgroup factor nil
"Factor mode"
:group 'languages)
@@ -82,23 +79,35 @@
:type 'hook
:group 'factor)
+(defconst factor--parsing-words
+ '("{" "}" "^:" "^::" ";" "<<" "<PRIVATE" ">>"
+ "BIN:" "BV{" "B{" "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CS{" "C{"
+ "DEFER:" "ERROR:" "FORGET:"
+ "GENERIC#" "GENERIC:" "HEX:" "HOOK:" "H{"
+ "IN:" "INSTANCE:" "INTERSECTION:"
+ "M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "METHOD:" "MIXIN:"
+ "OCT:" "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
+ "REQUIRE:" "REQUIRES:" "SINGLETON:" "SLOT:" "SYMBOL:" "SYMBOLS:"
+ "TUPLE:" "T{" "t\\??" "TYPEDEF:"
+ "UNION:" "USE:" "USING:" "V{" "VAR:" "VARS:" "W{"))
+
+(defconst factor--regex--parsing-words-ext
+ (regexp-opt '("B" "call-next-method" "delimiter" "f" "flushable" "foldable"
+ "initial:" "inline" "parsing" "read-only" "recursive")
+ 'words))
+
(defconst factor-font-lock-keywords
- '(("#!.*$" . font-lock-comment-face)
+ `(("#!.*$" . font-lock-comment-face)
("!( .* )" . font-lock-comment-face)
("^!.*$" . font-lock-comment-face)
(" !.*$" . font-lock-comment-face)
("( .* )" . font-lock-comment-face)
- "BIN:"
- "MAIN:"
- "IN:" "USING:" "TUPLE:" "^C:" "^M:"
- "METHOD:"
- "USE:" "REQUIRE:" "PROVIDE:"
- "REQUIRES:"
- "GENERIC:" "GENERIC#" "SYMBOL:" "PREDICATE:" "VAR:" "VARS:"
- "C-STRUCT:"
- "C-UNION:" "<PRIVATE" "PRIVATE>" "MACRO:" "MACRO::" "DEFER:" "TYPEDEF:"
- "SYMBOLS:"
-))
+ ("\"[^ ][^\"]*\"" . font-lock-string-face)
+ ("\\(P\\|SBUF\\)\"" 1 font-lock-keyword-face)
+ ,@(mapcar #'(lambda (w) (cons (concat "\\(^\\| \\)\\(" w "\\)\\($\\| \\)")
+ '(2 font-lock-keyword-face)))
+ factor--parsing-words)
+ (,factor--regex--parsing-words-ext . font-lock-keyword-face)))
(defun factor-indent-line ()
"Indent current line as Factor code"
@@ -116,7 +125,7 @@
(setq comment-start "! ")
(make-local-variable 'font-lock-defaults)
(setq font-lock-defaults
- '(factor-font-lock-keywords nil nil nil nil))
+ '(factor-font-lock-keywords t nil nil nil))
(set-syntax-table factor-mode-syntax-table)
(make-local-variable 'indent-line-function)
(setq indent-line-function 'factor-indent-line)
From 7a58500b0125b3e4bf108314a40c8949f800c7ce Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Thu, 13 Nov 2008 21:06:41 -0600
Subject: [PATCH 072/157] fix docs for hexdump
---
basis/tools/hexdump/hexdump-docs.factor | 6 +++---
basis/tools/hexdump/hexdump-tests.factor | 2 +-
2 files changed, 4 insertions(+), 4 deletions(-)
diff --git a/basis/tools/hexdump/hexdump-docs.factor b/basis/tools/hexdump/hexdump-docs.factor
index b24cc8ae33..9579fb7f81 100644
--- a/basis/tools/hexdump/hexdump-docs.factor
+++ b/basis/tools/hexdump/hexdump-docs.factor
@@ -12,11 +12,11 @@ HELP: hexdump
{ $description "Converts a sequence to its hexadecimal and ASCII representation sixteen characters at a time. Lines are separated by a newline character." }
{ $see-also hexdump. } ;
-ARTICLE: "hexdump" "Hexdump"
-"The " { $vocab-link "hexdump" } " vocabulary provides a traditional hexdump view of a sequence." $nl
+ARTICLE: "tools.hexdump" "Hexdump"
+"The " { $vocab-link "tools.hexdump" } " vocabulary provides a traditional hexdump view of a sequence." $nl
"Write hexdump to string:"
{ $subsection hexdump }
"Write the hexdump to the output stream:"
{ $subsection hexdump. } ;
-ABOUT: "hexdump"
+ABOUT: "tools.hexdump"
diff --git a/basis/tools/hexdump/hexdump-tests.factor b/basis/tools/hexdump/hexdump-tests.factor
index 1a638a8586..7202e4402c 100644
--- a/basis/tools/hexdump/hexdump-tests.factor
+++ b/basis/tools/hexdump/hexdump-tests.factor
@@ -1,4 +1,4 @@
-USING: hexdump kernel sequences tools.test ;
+USING: tools.hexdump kernel sequences tools.test ;
IN: tools.hexdump.tests
[ t ] [ "" hexdump "Length: 0, 0h\n" = ] unit-test
From b17dbcd39482777341c2a7b6f7b943972504596e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 13 Nov 2008 21:49:37 -0600
Subject: [PATCH 073/157] Document furnace.actions and clean up a few things
---
basis/furnace/actions/actions-docs.factor | 170 ++++++++++++++++++
basis/furnace/actions/actions.factor | 13 +-
.../features/edit-profile/edit-profile.xml | 2 +-
.../features/recover-password/recover-3.xml | 2 +-
.../auth/features/registration/register.xml | 2 +-
basis/furnace/auth/login/login.xml | 2 +-
.../conversations/conversations-docs.factor | 6 +
basis/html/forms/forms-docs.factor | 8 +
basis/html/forms/forms.factor | 13 +-
basis/html/templates/chloe/chloe-docs.factor | 3 +
basis/html/templates/chloe/chloe.factor | 3 +
extra/webapps/blogs/new-post.xml | 2 +-
extra/webapps/user-admin/edit-user.xml | 2 +-
extra/webapps/user-admin/new-user.xml | 2 +-
14 files changed, 209 insertions(+), 21 deletions(-)
create mode 100644 basis/furnace/actions/actions-docs.factor
create mode 100644 basis/furnace/conversations/conversations-docs.factor
diff --git a/basis/furnace/actions/actions-docs.factor b/basis/furnace/actions/actions-docs.factor
new file mode 100644
index 0000000000..509e0bcdee
--- /dev/null
+++ b/basis/furnace/actions/actions-docs.factor
@@ -0,0 +1,170 @@
+USING: assocs classes help.markup help.syntax io.streams.string
+http http.server.dispatchers http.server.responses
+furnace.redirection strings multiline ;
+IN: furnace.actions
+
+HELP: <action>
+{ $values { "action" action } }
+{ $description "Creates a new action." } ;
+
+HELP: <chloe-content>
+{ $values
+ { "path" "a pathname string" }
+ { "response" response }
+}
+{ $description "Creates an HTTP response which serves a Chloe template. See " { $link "html.templates.chloe" } "." } ;
+
+HELP: <page-action>
+{ $values { "page" action } }
+{ $description "Creates a new action which serves a Chloe template when servicing a GET request." } ;
+
+HELP: action
+{ $description "The class of Furnace actions. New instances are created with " { $link <action> } ". New instances of subclasses can be created with " { $link new-action } ". The " { $link page-action } " class is a useful subclass."
+$nl
+"Action slots are documented in " { $link "furnace.actions.config" } "." } ;
+
+HELP: new-action
+{ $values
+ { "class" class }
+ { "action" action }
+}
+{ $description "Constructs a subclass of " { $link action } "." } ;
+
+HELP: page-action
+{ $description "The class of Chloe page actions. These are actions whose " { $slot "display" } " slot is pre-set to serve the Chloe template stored in the " { $slot "page" } " slot." } ;
+
+HELP: param
+{ $values
+ { "name" string }
+ { "value" string }
+}
+{ $description "Outputs the value of a query parameter (if the current request is a GET or HEAD request) or a POST parameter (if the current request is a POST request)." }
+{ $notes "Instead of using this word, it is better to use " { $link validate-params } " and then access parameters via " { $link "html.forms.values" } " words." } ;
+
+HELP: params
+{ $var-description "A variable holding an assoc of query parameters (if the current request is a GET or HEAD request) or POST parameters (if the current request is a POST request)." }
+{ $notes "Instead of using this word, it is better to use " { $link validate-params } " and then access parameters via " { $link "html.forms.values" } " words." } ;
+
+HELP: validate-integer-id
+{ $description "A utility word which validates an integer parameter named " { $snippet "id" } "." }
+{ $examples
+ { $code
+ "<action>"
+ " ["
+ " validate-integer-id"
+ " \"id\" value <person> select-tuple from-object"
+ " ] >>init"
+ }
+} ;
+
+HELP: validate-params
+{ $values
+ { "validators" "an association list mapping parameter names to validator quotations" }
+}
+{ $description "Validates query or POST parameters, depending on the request type, and stores them in " { $link "html.forms.values" } ". The validator quotations can execute " { $link "validators" } "." }
+{ $examples
+ "A simple validator from " { $vocab-link "webapps.todo" } "; this word is invoked from the " { $slot "validate" } " quotation of action for editing a todo list item:"
+ { $code
+ <" : validate-todo ( -- )
+ {
+ { "summary" [ v-one-line ] }
+ { "priority" [ v-integer 0 v-min-value 10 v-max-value ] }
+ { "description" [ v-required ] }
+ } validate-params ;">
+ }
+} ;
+
+HELP: validation-failed
+{ $description "Stops processing the current request and takes action depending on the type of the current request:"
+ { $list
+ { "For GET or HEAD requests, the client receives a " { $link <400> } " response." }
+ { "For POST requests, the client is sent back to the page containing the form submission, with current form values and validation errors passed in a " { $link "furnace.conversations" } "." }
+ }
+"This word is called by " { $link validate-params } " and can also be called directly. For more details, see " { $link "furnace.actions.lifecycle" } "." } ;
+
+ARTICLE: "furnace.actions.page.example" "Furnace page action example"
+"The " { $vocab-link "webapps.counter" } " vocabulary defines a subclass of " { $link dispatcher } ":"
+{ $code "TUPLE: counter-app < dispatcher ;" }
+"The " { $snippet "<counter-app>" } " constructor word creates a new instance of the " { $snippet "counter-app" } " class, and adds a " { $link page-action } " instance to the dispatcher. This " { $link page-action } " has its " { $slot "template" } " slot set as follows,"
+{ $code "{ counter-app \"counter\" } >>template" }
+"This means the action will serve the Chloe template located at " { $snippet "resource:extra/webapps/counter/counter.xml" } " upon receiving a GET request." ;
+
+ARTICLE: "furnace.actions.page" "Furnace page actions"
+"Page actions implement the common case of an action that simply serves a Chloe template in response to a GET request."
+{ $subsection page-action }
+{ $subsection <page-action> }
+"When using a page action, instead of setting the " { $slot "display" } " slot, the " { $slot "template" } " slot is set instead. The " { $slot "init" } ", " { $slot "authorize" } ", " { $slot "validate" } " and " { $slot "submit" } " slots can still be set as usual."
+$nl
+"The " { $slot "template" } " slot of a " { $link page-action } " contains a pair with shape " { $snippet "{ responder name }" } ", where " { $snippet "responder" } " is a responder class, usually a subclass of " { $link dispatcher } ", and " { $snippet "name" } " is the name of a template file, without the " { $snippet ".xml" } " extension, relative to the directory containing the responder's vocabulary source file."
+{ $subsection "furnace.actions.page.example" } ;
+
+ARTICLE: "furnace.actions.config" "Furnace action configuration"
+"Actions have the following slots:"
+{ $table
+ { { $slot "rest" } { "A parameter name to map the rest of the URL, after the action name, to. If this is not set, then navigating to a URL where the action is not the last path component will return to the client with an error." } }
+ { { $slot "init" } { "A quotation called at the beginning of a GET or HEAD request. Typically this quotation configures " { $link "html.forms" } " and parses query parameters." } }
+ { { $slot "authorize" } { "A quotation called at the beginning of a GET, HEAD or POST request. In GET requests, it is called after the " { $slot "init" } " quotation; in POST requests, it is called after the " { $slot "validate" } " quotation. By convention, this quotation performs custom authorization checks which depend on query parameters or POST parameters." } }
+ { { $slot "display" } { "A quotation called after the " { $slot "init" } " quotation in a GET request. This quotation must return an HTTP " { $link response } "." } }
+ { { $slot "validate" } { "A quotation called at the beginning of a POST request to validate POST parameters." } }
+ { { $slot "submit" } { "A quotation called after the " { $slot "validate" } " quotation in a POST request. This quotation must return an HTTP " { $link response } "." } }
+}
+"At least one of the " { $slot "display" } " and " { $slot "submit" } " slots must be set, otherwise the action will be useless." ;
+
+ARTICLE: "furnace.actions.validation" "Form validation with actions"
+"The action code is set up so that the " { $slot "init" } " quotation can validate query parameters, and the " { $slot "validate" } " quotation can validate POST parameters."
+$nl
+"A word to validate parameters and make them available as HTML form values (see " { $link "html.forms.values" } "); typically this word is invoked from the " { $slot "init" } " and " { $slot "validate" } " quotations:"
+{ $subsection validate-params }
+"The above word expects an association list mapping parameter names to validator quotations; validator quotations can use the words in the "
+"Custom validation logic can invoke a word when validation fails; " { $link validate-params } " invokes this word for you:"
+{ $subsection validation-failed }
+"If validation fails, no more action code is executed, and the client is redirected back to the originating page, where validation errors can be displayed. Note that validation errors are rendered automatically by the " { $link "html.components" } " words, and in particular, " { $link "html.templates.chloe" } " use these words." ;
+
+ARTICLE: "furnace.actions.lifecycle" "Furnace action lifecycle"
+{ $heading "GET request lifecycle" }
+"A GET request results in the following sequence of events:"
+{ $list
+ { "The " { $snippet "init" } " quotation is called." }
+ { "The " { $snippet "authorize" } " quotation is called." }
+ { "If the GET request was generated as a result of form validation failing during a POST, then the form values entered by the user, along with validation errors, are stored in " { $link "html.forms.values" } "." }
+ { "The " { $snippet "display" } " quotation is called; it is expected to output an HTTP " { $link response } " on the stack." }
+}
+"Any one of the above steps can perform validation; if " { $link validation-failed } " is called during a GET request, the client receives a " { $link <400> } " error."
+{ $heading "HEAD request lifecycle" }
+"A HEAD request proceeds exactly like a GET request. The only difference is that the " { $slot "body" } " slot of the " { $link response } " object is never rendered."
+{ $heading "POST request lifecycle" }
+"A POST request results in the following sequence of events:"
+{ $list
+ { "The " { $snippet "validate" } " quotation is called." }
+ { "The " { $snippet "authorize" } " quotation is called." }
+ { "The " { $snippet "submit" } " quotation is called; it is expected to output an HTTP " { $link response } " on the stack. By convention, this response should be a " { $link <redirect> } "." }
+}
+"Any one of the above steps can perform validation; if " { $link validation-failed } " is called during a POST request, the client is sent back to the page containing the form submission, with current form values and validation errors passed in a " { $link "furnace.conversations" } "." ;
+
+ARTICLE: "furnace.actions.impl" "Furnace actions implementation"
+"The following words are used by the action implementation and there is rarely any reason to call them directly:"
+{ $subsection new-action }
+{ $subsection param }
+{ $subsection params } ;
+
+ARTICLE: "furnace.actions" "Furnace actions"
+"The " { $vocab-link "furnace.actions" } " vocabulary implements a type of responder, called an " { $emphasis "action" } ", which handles the form validation lifecycle."
+$nl
+"Other than form validation capability, actions are also often simpler to use than implementing new responders directly, since creating a new class is not required, and the action dispatches on the request type (GET, HEAD, or POST)."
+$nl
+"The class of actions:"
+{ $subsection action }
+"Creating a new action:"
+{ $subsection <action> }
+"Once created, an action needs to be configured; typically the creation and configuration of an action is encapsulated into a single word:"
+{ $subsection "furnace.actions.config" }
+"Validating forms with actions:"
+{ $subsection "furnace.actions.validation" }
+"More about the form validation lifecycle:"
+{ $subsection "furnace.actions.lifecycle" }
+"A convenience class:"
+{ $subsection "furnace.actions.page" }
+"Low-level features:"
+{ $subsection "furnace.actions.impl" } ;
+
+ABOUT: "furnace.actions"
diff --git a/basis/furnace/actions/actions.factor b/basis/furnace/actions/actions.factor
index 7505b3c612..6c56a8ad7b 100644
--- a/basis/furnace/actions/actions.factor
+++ b/basis/furnace/actions/actions.factor
@@ -22,18 +22,7 @@ SYMBOL: params
SYMBOL: rest
-: render-validation-messages ( -- )
- form get errors>>
- [
- <ul "errors" =class ul>
- [ <li> escape-string write </li> ] each
- </ul>
- ] unless-empty ;
-
-CHLOE: validation-messages
- drop [ render-validation-messages ] [code] ;
-
-TUPLE: action rest authorize init display validate submit ;
+TUPLE: action rest init authorize display validate submit ;
: new-action ( class -- action )
new [ ] >>init [ ] >>validate [ ] >>authorize ; inline
diff --git a/basis/furnace/auth/features/edit-profile/edit-profile.xml b/basis/furnace/auth/features/edit-profile/edit-profile.xml
index f486f4e246..878bdd64fb 100644
--- a/basis/furnace/auth/features/edit-profile/edit-profile.xml
+++ b/basis/furnace/auth/features/edit-profile/edit-profile.xml
@@ -62,7 +62,7 @@
<p>
<button>Update</button>
- <t:validation-messages />
+ <t:validation-errors />
</p>
</t:form>
diff --git a/basis/furnace/auth/features/recover-password/recover-3.xml b/basis/furnace/auth/features/recover-password/recover-3.xml
index a8ea635a1f..2df400ffe2 100644
--- a/basis/furnace/auth/features/recover-password/recover-3.xml
+++ b/basis/furnace/auth/features/recover-password/recover-3.xml
@@ -32,7 +32,7 @@
<p>
<button>Set password</button>
- <t:validation-messages />
+ <t:validation-errors />
</p>
</t:form>
diff --git a/basis/furnace/auth/features/registration/register.xml b/basis/furnace/auth/features/registration/register.xml
index b0d6971d1b..45c090905e 100644
--- a/basis/furnace/auth/features/registration/register.xml
+++ b/basis/furnace/auth/features/registration/register.xml
@@ -63,7 +63,7 @@
<p>
<button>Register</button>
- <t:validation-messages />
+ <t:validation-errors />
</p>
diff --git a/basis/furnace/auth/login/login.xml b/basis/furnace/auth/login/login.xml
index 766c097ca5..917c182fb3 100644
--- a/basis/furnace/auth/login/login.xml
+++ b/basis/furnace/auth/login/login.xml
@@ -36,7 +36,7 @@
<p>
<button>Log in</button>
- <t:validation-messages />
+ <t:validation-errors />
</p>
diff --git a/basis/furnace/conversations/conversations-docs.factor b/basis/furnace/conversations/conversations-docs.factor
new file mode 100644
index 0000000000..5e161f2457
--- /dev/null
+++ b/basis/furnace/conversations/conversations-docs.factor
@@ -0,0 +1,6 @@
+USING: help.markup help.syntax ;
+IN: furnace.conversations
+
+ARTICLE: "furnace.conversations" "Furnace conversation scope"
+
+;
diff --git a/basis/html/forms/forms-docs.factor b/basis/html/forms/forms-docs.factor
index 6556d2eac2..089a516072 100644
--- a/basis/html/forms/forms-docs.factor
+++ b/basis/html/forms/forms-docs.factor
@@ -85,6 +85,14 @@ HELP: validate-values
{ $values { "assoc" assoc } { "validators" "an assoc mapping value names to quotations" } }
{ $description "Validates values in the assoc by looking up the corresponding validation quotation, and storing the results in named values of the current form." } ;
+HELP: validation-error
+{ $values { "message" string } }
+{ $description "Reports a validation error not associated with a specific form field." }
+{ $notes "Such errors can be rendered by calling the " { $link render-validation-errors } " word." } ;
+
+HELP: render-validation-errors
+{ $description "Renders any validation errors reported by calls to the " { $link validation-error } " word." } ;
+
ARTICLE: "html.forms.forms" "HTML form infrastructure"
"The below words are used to implement the " { $vocab-link "furnace.actions" } " vocabulary. Calling them directly is rarely necessary."
$nl
diff --git a/basis/html/forms/forms.factor b/basis/html/forms/forms.factor
index c1c1aa3def..f92f8d0764 100644
--- a/basis/html/forms/forms.factor
+++ b/basis/html/forms/forms.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors strings namespaces assocs hashtables
-mirrors math fry sequences words continuations ;
+USING: kernel accessors strings namespaces assocs hashtables io
+mirrors math fry sequences words continuations html.elements
+xml.entities ;
IN: html.forms
TUPLE: form errors values validation-failed ;
@@ -104,3 +105,11 @@ C: <validation-error> validation-error
: validate-values ( assoc validators -- )
swap '[ [ dup _ at ] dip validate-value ] assoc-each ;
+
+: render-validation-errors ( -- )
+ form get errors>>
+ [
+ <ul "errors" =class ul>
+ [ <li> escape-string write </li> ] each
+ </ul>
+ ] unless-empty ;
diff --git a/basis/html/templates/chloe/chloe-docs.factor b/basis/html/templates/chloe/chloe-docs.factor
index f390aad238..402b6e68a9 100644
--- a/basis/html/templates/chloe/chloe-docs.factor
+++ b/basis/html/templates/chloe/chloe-docs.factor
@@ -154,6 +154,9 @@ ARTICLE: "html.templates.chloe.tags.form" "Chloe link and form tags"
"</t:button>"
}
} }
+ { { $snippet "t:validation-errors" } {
+ "Renders validation errors in the current form which are not associated with any field. Such errors are reported by invoking " { $link validation-error } "."
+ } }
} ;
ARTICLE: "html.templates.chloe.tags" "Standard Chloe tags"
diff --git a/basis/html/templates/chloe/chloe.factor b/basis/html/templates/chloe/chloe.factor
index 1bc4684d5c..da3f80e9a5 100644
--- a/basis/html/templates/chloe/chloe.factor
+++ b/basis/html/templates/chloe/chloe.factor
@@ -65,6 +65,9 @@ CHLOE: comment drop ;
CHLOE: call-next-template
drop reset-buffer \ call-next-template , ;
+CHLOE: validation-errors
+ drop [ render-validation-errors ] [code] ;
+
: attr>word ( value -- word/f )
":" split1 swap lookup ;
diff --git a/extra/webapps/blogs/new-post.xml b/extra/webapps/blogs/new-post.xml
index 9cb0250518..a2741ccd4e 100644
--- a/extra/webapps/blogs/new-post.xml
+++ b/extra/webapps/blogs/new-post.xml
@@ -13,5 +13,5 @@
</t:form>
</div>
- <t:validation-messages />
+ <t:validation-errors />
</t:chloe>
diff --git a/extra/webapps/user-admin/edit-user.xml b/extra/webapps/user-admin/edit-user.xml
index f41e8a97b4..27b6beaec6 100644
--- a/extra/webapps/user-admin/edit-user.xml
+++ b/extra/webapps/user-admin/edit-user.xml
@@ -51,7 +51,7 @@
<p>
<button type="submit" >Update</button>
- <t:validation-messages />
+ <t:validation-errors />
</p>
</t:form>
diff --git a/extra/webapps/user-admin/new-user.xml b/extra/webapps/user-admin/new-user.xml
index 7acdd384ba..d3cf681165 100644
--- a/extra/webapps/user-admin/new-user.xml
+++ b/extra/webapps/user-admin/new-user.xml
@@ -46,7 +46,7 @@
<p>
<button type="submit" class="link-button link">Create</button>
- <t:validation-messages />
+ <t:validation-errors />
</p>
</t:form>
From faeacba224d549f50f7c769da41c0d6f853cdbc2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 13 Nov 2008 23:21:32 -0600
Subject: [PATCH 074/157] furnace.alloy docs
---
basis/furnace/alloy/alloy-docs.factor | 42 ++++++
basis/furnace/asides/asides-docs.factor | 33 +++++
basis/furnace/db/db-docs.factor | 20 +++
basis/furnace/sessions/sessions-docs.factor | 149 ++++++++++++++++++++
4 files changed, 244 insertions(+)
create mode 100644 basis/furnace/alloy/alloy-docs.factor
create mode 100644 basis/furnace/asides/asides-docs.factor
create mode 100644 basis/furnace/db/db-docs.factor
create mode 100644 basis/furnace/sessions/sessions-docs.factor
diff --git a/basis/furnace/alloy/alloy-docs.factor b/basis/furnace/alloy/alloy-docs.factor
new file mode 100644
index 0000000000..d07d534510
--- /dev/null
+++ b/basis/furnace/alloy/alloy-docs.factor
@@ -0,0 +1,42 @@
+IN: furnace.alloy
+USING: help.markup help.syntax db multiline ;
+
+HELP: init-furnace-tables
+{ $description "Initializes database tables used by asides, conversations and session management. This word must be invoked inside a " { $link with-db } " scope." } ;
+
+HELP: <alloy>
+{ $values { "responder" "a responder" } { "db" db } { "alloy" "an alloy responder" } }
+{ $description "Wraps the responder with support for asides, conversations, sessions and database persistence." }
+{ $examples
+ "The " { $vocab-link "webapps.counter" } " vocabulary uses an alloy to configure the counter:"
+ { $code
+ <" : counter-db ( -- db ) "counter.db" <sqlite-db> ;
+
+: run-counter ( -- )
+ <counter-app>
+ counter-db <alloy>
+ main-responder set-global
+ 8080 httpd ;">
+ }
+} ;
+
+HELP: start-expiring
+{ $values { "db" db } }
+{ $description "Starts a timer which expires old session state from the given database." } ;
+
+ARTICLE: "furnace.alloy" "Furnace alloy responder"
+"The " { $vocab-link "furnace.alloy" } " vocabulary implements a convenience responder which combines several Furnace features into one easy-to-use wrapper:"
+{ $list
+ { $link "furnace.asides" }
+ { $link "furnace.conversations" }
+ { $link "furnace.sessions" }
+ { $link "furnace.db" }
+}
+"A word to wrap a responder in an alloy:"
+{ $subsection <alloy> }
+"Initializing database tables for asides, conversations and sessions:"
+{ $subsection init-furnace-tables }
+"Start a timer to expire asides, conversations and sessions:"
+{ $subsection start-expiring } ;
+
+ABOUT: "furnace.alloy"
diff --git a/basis/furnace/asides/asides-docs.factor b/basis/furnace/asides/asides-docs.factor
new file mode 100644
index 0000000000..b977474b5f
--- /dev/null
+++ b/basis/furnace/asides/asides-docs.factor
@@ -0,0 +1,33 @@
+USING: help.markup help.syntax io.streams.string urls
+furnace.redirection http furnace.sessions furnace.db ;
+IN: furnace.asides
+
+HELP: <asides>
+{ $values
+ { "responder" "a responder" }
+ { "responder'" asides }
+}
+{ $description "Creates a new " { $link asides } " responder wrapping an existing responder." } ;
+
+HELP: begin-aside
+{ $values { "url" url } }
+{ $description "Begins an aside. When the current action returns a " { $link <redirect> } ", the redirect will have query parameters which reference the current page via an opaque handle." } ;
+
+HELP: end-aside
+{ $values { "default" url } { "response" response } }
+{ $description "Ends an aside. If an aside is currently active, the response redirects the client " } ;
+
+ARTICLE: "furnace.asides" "Furnace asides"
+"The " { $vocab-link "furnace.asides" } " vocabulary provides support for sending a user to a page which can then return to the former location."
+$nl
+"To use asides, wrap your responder in an aside responder:"
+{ $subsection <asides> }
+"The aside responder must be wrapped inside a session responder (" { $link <sessions> } "), which in turn must be wrapped inside a database persistence responder (" { $link <db-persistence> } "). The " { $vocab-link "furnace.alloy" } " vocabulary combines all of these responders into one."
+$nl
+"Saving the current page in an aside which propagates through " { $link <redirect> } " responses:"
+{ $subsection begin-aside }
+"Returning from an aside:"
+{ $subsection end-aside }
+"Asides are used by " { $vocab-link "furnace.auth.login" } "; when the client requests a protected page, an aside begins and the client is redirected to a login page. Upon a successful login, the aside ends and the client returns to the protected page. If the client directly visits the login page and logs in, there is no current aside, so the client is sent to the default URL passed to " { $link end-aside } ", which in the case of login is the root URL." ;
+
+ABOUT: "furnace.asides"
diff --git a/basis/furnace/db/db-docs.factor b/basis/furnace/db/db-docs.factor
new file mode 100644
index 0000000000..367a806d36
--- /dev/null
+++ b/basis/furnace/db/db-docs.factor
@@ -0,0 +1,20 @@
+! Copyright (C) 2008 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io.streams.string ;
+IN: furnace.db
+
+HELP: <db-persistence>
+{ $values
+ { "responder" null } { "db" null }
+ { "responder'" null }
+}
+{ $description "" } ;
+
+HELP: db-persistence
+{ $description "" } ;
+
+ARTICLE: "furnace.db" "Furnace database support"
+{ $vocab-link "furnace.db" }
+;
+
+ABOUT: "furnace.db"
diff --git a/basis/furnace/sessions/sessions-docs.factor b/basis/furnace/sessions/sessions-docs.factor
new file mode 100644
index 0000000000..6ec77e00f5
--- /dev/null
+++ b/basis/furnace/sessions/sessions-docs.factor
@@ -0,0 +1,149 @@
+! Copyright (C) 2008 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io.streams.string quotations strings ;
+IN: furnace.sessions
+
+HELP: <session-cookie>
+{ $values
+
+ { "cookie" null }
+}
+{ $description "" } ;
+
+HELP: <session>
+{ $values
+ { "id" null }
+ { "session" null }
+}
+{ $description "" } ;
+
+HELP: <sessions>
+{ $values
+ { "responder" null }
+ { "responder'" null }
+}
+{ $description "" } ;
+
+HELP: begin-session
+{ $values
+
+ { "session" null }
+}
+{ $description "" } ;
+
+HELP: check-session
+{ $values
+ { "state/f" null }
+ { "state/f" null }
+}
+{ $description "" } ;
+
+HELP: empty-session
+{ $values
+
+ { "session" null }
+}
+{ $description "" } ;
+
+HELP: existing-session
+{ $values
+ { "path" "a pathname string" } { "session" null }
+ { "response" null }
+}
+{ $description "" } ;
+
+HELP: get-session
+{ $values
+ { "id" null }
+ { "session" null }
+}
+{ $description "" } ;
+
+HELP: init-session
+{ $values
+ { "session" null }
+}
+{ $description "" } ;
+
+HELP: init-session*
+{ $values
+ { "responder" null }
+}
+{ $description "" } ;
+
+HELP: put-session-cookie
+{ $values
+ { "response" null }
+ { "response'" null }
+}
+{ $description "" } ;
+
+HELP: remote-host
+{ $values
+
+ { "string" string }
+}
+{ $description "" } ;
+
+HELP: request-session
+{ $values
+
+ { "session/f" null }
+}
+{ $description "" } ;
+
+HELP: save-session-after
+{ $values
+ { "session" null }
+}
+{ $description "" } ;
+
+HELP: schange
+{ $values
+ { "key" null } { "quot" quotation }
+}
+{ $description "" } ;
+
+HELP: session
+{ $description "" } ;
+
+HELP: session-changed
+{ $description "" } ;
+
+HELP: session-id-key
+{ $description "" } ;
+
+HELP: sessions
+{ $description "" } ;
+
+HELP: sget
+{ $values
+ { "key" null }
+ { "value" null }
+}
+{ $description "" } ;
+
+HELP: sset
+{ $values
+ { "value" null } { "key" null }
+}
+{ $description "" } ;
+
+HELP: touch-session
+{ $values
+ { "session" null }
+}
+{ $description "" } ;
+
+HELP: verify-session
+{ $values
+ { "session" null }
+ { "session" null }
+}
+{ $description "" } ;
+
+ARTICLE: "furnace.sessions" "Furnace sessions"
+{ $vocab-link "furnace.sessions" }
+;
+
+ABOUT: "furnace.sessions"
From f78c5b4d207247f2027347818d8b0c86f9552d65 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 13 Nov 2008 23:35:00 -0600
Subject: [PATCH 075/157] Write furnace.db docs
---
basis/furnace/db/db-docs.factor | 18 +++++++-----------
1 file changed, 7 insertions(+), 11 deletions(-)
diff --git a/basis/furnace/db/db-docs.factor b/basis/furnace/db/db-docs.factor
index 367a806d36..a7ef02b77f 100644
--- a/basis/furnace/db/db-docs.factor
+++ b/basis/furnace/db/db-docs.factor
@@ -1,20 +1,16 @@
-! Copyright (C) 2008 Your name.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax io.streams.string ;
+USING: help.markup help.syntax db http.server ;
IN: furnace.db
HELP: <db-persistence>
{ $values
- { "responder" null } { "db" null }
- { "responder'" null }
+ { "responder" "a responder" } { "db" db }
+ { "responder'" db-persistence }
}
-{ $description "" } ;
-
-HELP: db-persistence
-{ $description "" } ;
+{ $description "Wraps a responder with database persistence support. The responder's " { $link call-responder* } " method will run in a " { $link with-db } " scope." } ;
ARTICLE: "furnace.db" "Furnace database support"
-{ $vocab-link "furnace.db" }
-;
+"The " { $vocab-link "furnace.db" } " vocabulary implements a responder which maintains a database connection pool and runs each request in a " { $link with-db } " scope."
+{ $subsection <db-persistence> }
+"The " { $vocab-link "furnace.alloy" } " vocabulary combines database persistence with several other features." ;
ABOUT: "furnace.db"
From 29249e2a64708ab3145973329892239ba126495a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 13 Nov 2008 23:59:30 -0600
Subject: [PATCH 076/157] Document furnace.json
---
basis/furnace/json/json-docs.factor | 12 ++++++++++++
1 file changed, 12 insertions(+)
create mode 100644 basis/furnace/json/json-docs.factor
diff --git a/basis/furnace/json/json-docs.factor b/basis/furnace/json/json-docs.factor
new file mode 100644
index 0000000000..daa84e9295
--- /dev/null
+++ b/basis/furnace/json/json-docs.factor
@@ -0,0 +1,12 @@
+USING: kernel http.server help.markup help.syntax ;
+IN: furnace.json
+
+HELP: <json-content>
+{ $values { "body" object } { "response" response } }
+{ $description "Creates an HTTP response which serves a serialized JSON object to the client." } ;
+
+ARTICLE: "furnace.json" "Furnace JSON support"
+"The " { $vocab-link "furnace.json" } " vocabulary provides a utility word for serving HTTP responses with JSON content."
+{ $subsection <json-content> } ;
+
+ABOUT: "furnace.json"
From 5f6421af5d26ff14e5179898d1ad54b34962edbe Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 14 Nov 2008 00:03:24 -0600
Subject: [PATCH 077/157] use win32-file-attributes word
---
basis/io/windows/files/files.factor | 43 ++++++++++++++++-------------
1 file changed, 24 insertions(+), 19 deletions(-)
diff --git a/basis/io/windows/files/files.factor b/basis/io/windows/files/files.factor
index e3b96b98d8..d0409ce59a 100755
--- a/basis/io/windows/files/files.factor
+++ b/basis/io/windows/files/files.factor
@@ -149,35 +149,39 @@ SYMBOLS: +read-only+ +hidden+ +system+
+sparse-file+ +reparse-point+ +compressed+ +offline+
+not-content-indexed+ +encrypted+ ;
-: win32-file-attribute ( n attr symbol -- n )
- >r dupd mask? r> swap [ , ] [ drop ] if ;
+TUPLE: windows-file-info < file-info attributes ;
+
+: win32-file-attribute ( n attr symbol -- )
+ rot mask? [ , ] [ drop ] if ;
: win32-file-attributes ( n -- seq )
[
- FILE_ATTRIBUTE_READONLY +read-only+ win32-file-attribute
- FILE_ATTRIBUTE_HIDDEN +hidden+ win32-file-attribute
- FILE_ATTRIBUTE_SYSTEM +system+ win32-file-attribute
- FILE_ATTRIBUTE_DIRECTORY +directory+ win32-file-attribute
- FILE_ATTRIBUTE_ARCHIVE +archive+ win32-file-attribute
- FILE_ATTRIBUTE_DEVICE +device+ win32-file-attribute
- FILE_ATTRIBUTE_NORMAL +normal+ win32-file-attribute
- FILE_ATTRIBUTE_TEMPORARY +temporary+ win32-file-attribute
- FILE_ATTRIBUTE_SPARSE_FILE +sparse-file+ win32-file-attribute
- FILE_ATTRIBUTE_REPARSE_POINT +reparse-point+ win32-file-attribute
- FILE_ATTRIBUTE_COMPRESSED +compressed+ win32-file-attribute
- FILE_ATTRIBUTE_OFFLINE +offline+ win32-file-attribute
- FILE_ATTRIBUTE_NOT_CONTENT_INDEXED +not-content-indexed+ win32-file-attribute
- FILE_ATTRIBUTE_ENCRYPTED +encrypted+ win32-file-attribute
- drop
+ {
+ [ +read-only+ FILE_ATTRIBUTE_READONLY win32-file-attribute ]
+ [ +hidden+ FILE_ATTRIBUTE_HIDDEN win32-file-attribute ]
+ [ +system+ FILE_ATTRIBUTE_SYSTEM win32-file-attribute ]
+ [ +directory+ FILE_ATTRIBUTE_DIRECTORY win32-file-attribute ]
+ [ +archive+ FILE_ATTRIBUTE_ARCHIVE win32-file-attribute ]
+ [ +device+ FILE_ATTRIBUTE_DEVICE win32-file-attribute ]
+ [ +normal+ FILE_ATTRIBUTE_NORMAL win32-file-attribute ]
+ [ +temporary+ FILE_ATTRIBUTE_TEMPORARY win32-file-attribute ]
+ [ +sparse-file+ FILE_ATTRIBUTE_SPARSE_FILE win32-file-attribute ]
+ [ +reparse-point+ FILE_ATTRIBUTE_REPARSE_POINT win32-file-attribute ]
+ [ +compressed+ FILE_ATTRIBUTE_COMPRESSED win32-file-attribute ]
+ [ +offline+ FILE_ATTRIBUTE_OFFLINE win32-file-attribute ]
+ [ +not-content-indexed+ FILE_ATTRIBUTE_NOT_CONTENT_INDEXED win32-file-attribute ]
+ [ +encrypted+ FILE_ATTRIBUTE_ENCRYPTED win32-file-attribute ]
+ } cleave
] { } make ;
: win32-file-type ( n -- symbol )
FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;
: WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info )
- [ \ file-info new ] dip
+ [ \ windows-file-info new ] dip
{
[ WIN32_FIND_DATA-dwFileAttributes win32-file-type >>type ]
+ [ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes >>attributes ]
[
[ WIN32_FIND_DATA-nFileSizeLow ]
[ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit >>size
@@ -196,9 +200,10 @@ SYMBOLS: +read-only+ +hidden+ +system+
] keep ;
: BY_HANDLE_FILE_INFORMATION>file-info ( HANDLE_FILE_INFORMATION -- file-info )
- [ \ file-info new ] dip
+ [ \ windows-file-info new ] dip
{
[ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type >>type ]
+ [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-attributes >>attributes ]
[
[ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ]
[ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit >>size
From ba2d9bcd93e3249ebb99cfe82167a91b6812b2d4 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 14 Nov 2008 00:05:12 -0600
Subject: [PATCH 078/157] split list vocabulary into unix and windows sides
---
extra/ls/ls.factor | 57 ++++++++++-----------------------
extra/ls/unix/authors.txt | 1 +
extra/ls/unix/tags.txt | 1 +
extra/ls/unix/unix.factor | 41 ++++++++++++++++++++++++
extra/ls/windows/authors.txt | 1 +
extra/ls/windows/tags.txt | 1 +
extra/ls/windows/windows.factor | 20 ++++++++++++
7 files changed, 82 insertions(+), 40 deletions(-)
mode change 100644 => 100755 extra/ls/ls.factor
create mode 100755 extra/ls/unix/authors.txt
create mode 100644 extra/ls/unix/tags.txt
create mode 100755 extra/ls/unix/unix.factor
create mode 100755 extra/ls/windows/authors.txt
create mode 100644 extra/ls/windows/tags.txt
create mode 100755 extra/ls/windows/windows.factor
diff --git a/extra/ls/ls.factor b/extra/ls/ls.factor
old mode 100644
new mode 100755
index 3e21873fec..92aff714e6
--- a/extra/ls/ls.factor
+++ b/extra/ls/ls.factor
@@ -1,12 +1,10 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs combinators generalizations
-io.files io.unix.files math.parser sequences.lib calendar math
-kernel sequences unix.groups unix.users combinators.cleave
-strings combinators.short-circuit unicode.case ;
-IN: ls
+USING: accessors arrays combinators io io.files kernel
+math.parser sequences system vocabs.loader calendar
+sequences.lib ;
-TUPLE: ls-info path user group size ;
+IN: ls
: ls-time ( timestamp -- string )
[ hour>> ] [ minute>> ] bi
@@ -25,39 +23,18 @@ TUPLE: ls-info path user group size ;
: write>string ( ? -- string ) "w" "-" ? ; inline
-: execute-string ( str bools -- str' )
- swap {
- { { t t } [ >lower ] }
- { { t f } [ >upper ] }
- { { f t } [ drop "x" ] }
- [ 2drop "-" ]
- } case ;
+HOOK: execute>string os ( ? -- string )
-: permissions-string ( permissions -- str )
- {
- [ type>> file-type>ch 1string ]
- [ user-read? read>string ]
- [ user-write? write>string ]
- [ [ uid? ] [ user-execute? ] bi 2array "s" execute-string ]
- [ group-read? read>string ]
- [ group-write? write>string ]
- [ [ gid? ] [ group-execute? ] bi 2array "s" execute-string ]
- [ other-read? read>string ]
- [ other-write? write>string ]
- [ [ sticky? ] [ other-execute? ] bi 2array "t" execute-string ]
- } <arr> concat ;
+M: object execute>string ( ? -- string ) "x" "-" ? ; inline
-: ls ( path -- lines )
- [ [ [
- "" directory-files [
- dup file-info
- {
- [ permissions-string ]
- [ nlink>> number>string 3 CHAR: \s pad-left ]
- ! [ uid>> ]
- ! [ gid>> ]
- [ size>> number>string 15 CHAR: \s pad-left ]
- [ modified>> ls-timestamp ]
- } <arr> swap suffix " " join
- ] map
- ] with-group-cache ] with-user-cache ] with-directory ;
+HOOK: permissions-string os ( -- str )
+
+HOOK: (directory.) os ( path -- lines )
+
+: directory. ( path -- )
+ [ (directory.) ] with-directory-files [ print ] each ;
+
+{
+ { [ os unix? ] [ "ls.unix" ] }
+ { [ os windows? ] [ "ls.windows" ] }
+} cond require
\ No newline at end of file
diff --git a/extra/ls/unix/authors.txt b/extra/ls/unix/authors.txt
new file mode 100755
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/extra/ls/unix/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/extra/ls/unix/tags.txt b/extra/ls/unix/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/extra/ls/unix/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/extra/ls/unix/unix.factor b/extra/ls/unix/unix.factor
new file mode 100755
index 0000000000..9a3f832961
--- /dev/null
+++ b/extra/ls/unix/unix.factor
@@ -0,0 +1,41 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators combinators.cleave kernel system unicode.case
+io.unix.files ls ;
+IN: ls.unix
+
+M: unix execute-string ( str bools -- str' )
+ swap {
+ { { t t } [ >lower ] }
+ { { t f } [ >upper ] }
+ { { f t } [ drop "x" ] }
+ [ 2drop "-" ]
+ } case ;
+
+M: unix permissions-string ( permissions -- str )
+ {
+ [ type>> file-type>ch 1string ]
+ [ user-read? read>string ]
+ [ user-write? write>string ]
+ [ [ uid? ] [ user-execute? ] bi 2array "s" execute-string ]
+ [ group-read? read>string ]
+ [ group-write? write>string ]
+ [ [ gid? ] [ group-execute? ] bi 2array "s" execute-string ]
+ [ other-read? read>string ]
+ [ other-write? write>string ]
+ [ [ sticky? ] [ other-execute? ] bi 2array "t" execute-string ]
+ } <arr> concat ;
+
+M: unix ls ( path -- lines )
+ [ [
+ dup file-info
+ {
+ [ permissions-string ]
+ [ nlink>> number>string 3 CHAR: \s pad-left ]
+ ! [ uid>> ]
+ ! [ gid>> ]
+ [ size>> number>string 15 CHAR: \s pad-left ]
+ [ modified>> ls-timestamp ]
+ } <arr> swap suffix " " join
+ ] map
+ ] with-group-cache ] with-user-cache ;
\ No newline at end of file
diff --git a/extra/ls/windows/authors.txt b/extra/ls/windows/authors.txt
new file mode 100755
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/extra/ls/windows/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/extra/ls/windows/tags.txt b/extra/ls/windows/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/extra/ls/windows/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/extra/ls/windows/windows.factor b/extra/ls/windows/windows.factor
new file mode 100755
index 0000000000..b7d7eeeb0b
--- /dev/null
+++ b/extra/ls/windows/windows.factor
@@ -0,0 +1,20 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors calendar.format combinators combinators.cleave
+io.files kernel math.parser sequences splitting system ls sequences.lib ;
+IN: ls.windows
+
+: directory-or-size ( file-info -- str )
+ dup directory? [
+ drop "<DIR>" 20 CHAR: \s pad-right
+ ] [
+ size>> number>string 20 CHAR: \s pad-left
+ ] if ;
+
+M: windows (directory.) ( entries -- lines )
+ [
+ dup file-info {
+ [ modified>> timestamp>ymdhms " " split1 " " splice ]
+ [ directory-or-size ]
+ } <arr> swap suffix " " join
+ ] map ;
\ No newline at end of file
From 739f02d7c0c6e4e3127be8ecc989b1e3564f53d7 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 14 Nov 2008 00:25:00 -0600
Subject: [PATCH 079/157] move ls to io.files.listing
---
basis/io/files/listing/authors.txt | 1 +
basis/io/files/listing/listing-tests.factor | 6 +++
basis/io/files/listing/listing.factor | 39 ++++++++++++++++++
basis/io/files/listing/tags.txt | 1 +
basis/io/files/listing/unix/authors.txt | 1 +
basis/io/files/listing/unix/tags.txt | 1 +
basis/io/files/listing/unix/unix.factor | 41 +++++++++++++++++++
basis/io/files/listing/windows/authors.txt | 1 +
basis/io/files/listing/windows/tags.txt | 1 +
basis/io/files/listing/windows/windows.factor | 21 ++++++++++
10 files changed, 113 insertions(+)
create mode 100644 basis/io/files/listing/authors.txt
create mode 100644 basis/io/files/listing/listing-tests.factor
create mode 100755 basis/io/files/listing/listing.factor
create mode 100644 basis/io/files/listing/tags.txt
create mode 100755 basis/io/files/listing/unix/authors.txt
create mode 100644 basis/io/files/listing/unix/tags.txt
create mode 100755 basis/io/files/listing/unix/unix.factor
create mode 100755 basis/io/files/listing/windows/authors.txt
create mode 100644 basis/io/files/listing/windows/tags.txt
create mode 100755 basis/io/files/listing/windows/windows.factor
diff --git a/basis/io/files/listing/authors.txt b/basis/io/files/listing/authors.txt
new file mode 100644
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/basis/io/files/listing/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/basis/io/files/listing/listing-tests.factor b/basis/io/files/listing/listing-tests.factor
new file mode 100644
index 0000000000..a2347c8db9
--- /dev/null
+++ b/basis/io/files/listing/listing-tests.factor
@@ -0,0 +1,6 @@
+! Copyright (C) 2008 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test io.files.listing strings kernel ;
+IN: io.files.listing.tests
+
+[ ] [ "" directory. ] unit-test
diff --git a/basis/io/files/listing/listing.factor b/basis/io/files/listing/listing.factor
new file mode 100755
index 0000000000..314010b75d
--- /dev/null
+++ b/basis/io/files/listing/listing.factor
@@ -0,0 +1,39 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays combinators io io.files kernel
+math.parser sequences system vocabs.loader calendar ;
+
+IN: io.files.listing
+
+: ls-time ( timestamp -- string )
+ [ hour>> ] [ minute>> ] bi
+ [ number>string 2 CHAR: 0 pad-left ] bi@ ":" swap 3append ;
+
+: ls-timestamp ( timestamp -- string )
+ [ month>> month-abbreviation ]
+ [ day>> number>string 2 CHAR: \s pad-left ]
+ [
+ dup year>> dup now year>> =
+ [ drop ls-time ] [ nip number>string ] if
+ 5 CHAR: \s pad-left
+ ] tri 3array " " join ;
+
+: read>string ( ? -- string ) "r" "-" ? ; inline
+
+: write>string ( ? -- string ) "w" "-" ? ; inline
+
+HOOK: execute>string os ( ? -- string )
+
+M: object execute>string ( ? -- string ) "x" "-" ? ; inline
+
+HOOK: permissions-string os ( -- str )
+
+HOOK: (directory.) os ( path -- lines )
+
+: directory. ( path -- )
+ [ (directory.) ] with-directory-files [ print ] each ;
+
+{
+ { [ os unix? ] [ "io.files.listing.unix" ] }
+ { [ os windows? ] [ "io.files.listing.windows" ] }
+} cond require
diff --git a/basis/io/files/listing/tags.txt b/basis/io/files/listing/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/basis/io/files/listing/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/basis/io/files/listing/unix/authors.txt b/basis/io/files/listing/unix/authors.txt
new file mode 100755
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/basis/io/files/listing/unix/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/basis/io/files/listing/unix/tags.txt b/basis/io/files/listing/unix/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/basis/io/files/listing/unix/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/basis/io/files/listing/unix/unix.factor b/basis/io/files/listing/unix/unix.factor
new file mode 100755
index 0000000000..c7f25f001b
--- /dev/null
+++ b/basis/io/files/listing/unix/unix.factor
@@ -0,0 +1,41 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators kernel system unicode.case
+io.unix.files io.files.listing generalizations ;
+IN: io.files.listing.unix
+
+M: unix execute-string ( str bools -- str' )
+ swap {
+ { { t t } [ >lower ] }
+ { { t f } [ >upper ] }
+ { { f t } [ drop "x" ] }
+ [ 2drop "-" ]
+ } case ;
+
+M: unix permissions-string ( permissions -- str )
+ {
+ [ type>> file-type>ch 1string ]
+ [ user-read? read>string ]
+ [ user-write? write>string ]
+ [ [ uid? ] [ user-execute? ] bi 2array "s" execute-string ]
+ [ group-read? read>string ]
+ [ group-write? write>string ]
+ [ [ gid? ] [ group-execute? ] bi 2array "s" execute-string ]
+ [ other-read? read>string ]
+ [ other-write? write>string ]
+ [ [ sticky? ] [ other-execute? ] bi 2array "t" execute-string ]
+ } cleave 10 narray concat ;
+
+M: unix ls ( path -- lines )
+ [ [
+ dup file-info
+ {
+ [ permissions-string ]
+ [ nlink>> number>string 3 CHAR: \s pad-left ]
+ ! [ uid>> ]
+ ! [ gid>> ]
+ [ size>> number>string 15 CHAR: \s pad-left ]
+ [ modified>> ls-timestamp ]
+ } cleave 4 narray swap suffix " " join
+ ] map
+ ] with-group-cache ] with-user-cache ;
diff --git a/basis/io/files/listing/windows/authors.txt b/basis/io/files/listing/windows/authors.txt
new file mode 100755
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/basis/io/files/listing/windows/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/basis/io/files/listing/windows/tags.txt b/basis/io/files/listing/windows/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/basis/io/files/listing/windows/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/basis/io/files/listing/windows/windows.factor b/basis/io/files/listing/windows/windows.factor
new file mode 100755
index 0000000000..53481fc7f8
--- /dev/null
+++ b/basis/io/files/listing/windows/windows.factor
@@ -0,0 +1,21 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors calendar.format combinators io.files
+kernel math.parser sequences splitting system io.files.listing
+generalizations ;
+IN: io.files.listing.windows
+
+: directory-or-size ( file-info -- str )
+ dup directory? [
+ drop "<DIR>" 20 CHAR: \s pad-right
+ ] [
+ size>> number>string 20 CHAR: \s pad-left
+ ] if ;
+
+M: windows (directory.) ( entries -- lines )
+ [
+ dup file-info {
+ [ modified>> timestamp>ymdhms ]
+ [ directory-or-size ]
+ } cleave 2 narray swap suffix " " join
+ ] map ;
From bc97c989c9ca0f7708f494f4f779b0a9bd6cbf22 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 14 Nov 2008 00:37:56 -0600
Subject: [PATCH 080/157] remove ls
---
extra/ls/authors.txt | 1 -
extra/ls/ls-tests.factor | 6 -----
extra/ls/ls.factor | 40 --------------------------------
extra/ls/tags.txt | 1 -
extra/ls/unix/authors.txt | 1 -
extra/ls/unix/tags.txt | 1 -
extra/ls/unix/unix.factor | 41 ---------------------------------
extra/ls/windows/authors.txt | 1 -
extra/ls/windows/tags.txt | 1 -
extra/ls/windows/windows.factor | 20 ----------------
10 files changed, 113 deletions(-)
delete mode 100644 extra/ls/authors.txt
delete mode 100644 extra/ls/ls-tests.factor
delete mode 100755 extra/ls/ls.factor
delete mode 100644 extra/ls/tags.txt
delete mode 100755 extra/ls/unix/authors.txt
delete mode 100644 extra/ls/unix/tags.txt
delete mode 100755 extra/ls/unix/unix.factor
delete mode 100755 extra/ls/windows/authors.txt
delete mode 100644 extra/ls/windows/tags.txt
delete mode 100755 extra/ls/windows/windows.factor
diff --git a/extra/ls/authors.txt b/extra/ls/authors.txt
deleted file mode 100644
index 7c1b2f2279..0000000000
--- a/extra/ls/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Doug Coleman
diff --git a/extra/ls/ls-tests.factor b/extra/ls/ls-tests.factor
deleted file mode 100644
index b1c1f18472..0000000000
--- a/extra/ls/ls-tests.factor
+++ /dev/null
@@ -1,6 +0,0 @@
-! Copyright (C) 2008 Your name.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test ls strings kernel ;
-IN: ls.tests
-
-[ ] [ "" ls drop ] unit-test
diff --git a/extra/ls/ls.factor b/extra/ls/ls.factor
deleted file mode 100755
index 92aff714e6..0000000000
--- a/extra/ls/ls.factor
+++ /dev/null
@@ -1,40 +0,0 @@
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators io io.files kernel
-math.parser sequences system vocabs.loader calendar
-sequences.lib ;
-
-IN: ls
-
-: ls-time ( timestamp -- string )
- [ hour>> ] [ minute>> ] bi
- [ number>string 2 CHAR: 0 pad-left ] bi@ ":" splice ;
-
-: ls-timestamp ( timestamp -- string )
- [ month>> month-abbreviation ]
- [ day>> number>string 2 CHAR: \s pad-left ]
- [
- dup year>> dup now year>> =
- [ drop ls-time ] [ nip number>string ] if
- 5 CHAR: \s pad-left
- ] tri 3array " " join ;
-
-: read>string ( ? -- string ) "r" "-" ? ; inline
-
-: write>string ( ? -- string ) "w" "-" ? ; inline
-
-HOOK: execute>string os ( ? -- string )
-
-M: object execute>string ( ? -- string ) "x" "-" ? ; inline
-
-HOOK: permissions-string os ( -- str )
-
-HOOK: (directory.) os ( path -- lines )
-
-: directory. ( path -- )
- [ (directory.) ] with-directory-files [ print ] each ;
-
-{
- { [ os unix? ] [ "ls.unix" ] }
- { [ os windows? ] [ "ls.windows" ] }
-} cond require
\ No newline at end of file
diff --git a/extra/ls/tags.txt b/extra/ls/tags.txt
deleted file mode 100644
index 6bf68304bb..0000000000
--- a/extra/ls/tags.txt
+++ /dev/null
@@ -1 +0,0 @@
-unportable
diff --git a/extra/ls/unix/authors.txt b/extra/ls/unix/authors.txt
deleted file mode 100755
index 7c1b2f2279..0000000000
--- a/extra/ls/unix/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Doug Coleman
diff --git a/extra/ls/unix/tags.txt b/extra/ls/unix/tags.txt
deleted file mode 100644
index 6bf68304bb..0000000000
--- a/extra/ls/unix/tags.txt
+++ /dev/null
@@ -1 +0,0 @@
-unportable
diff --git a/extra/ls/unix/unix.factor b/extra/ls/unix/unix.factor
deleted file mode 100755
index 9a3f832961..0000000000
--- a/extra/ls/unix/unix.factor
+++ /dev/null
@@ -1,41 +0,0 @@
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators combinators.cleave kernel system unicode.case
-io.unix.files ls ;
-IN: ls.unix
-
-M: unix execute-string ( str bools -- str' )
- swap {
- { { t t } [ >lower ] }
- { { t f } [ >upper ] }
- { { f t } [ drop "x" ] }
- [ 2drop "-" ]
- } case ;
-
-M: unix permissions-string ( permissions -- str )
- {
- [ type>> file-type>ch 1string ]
- [ user-read? read>string ]
- [ user-write? write>string ]
- [ [ uid? ] [ user-execute? ] bi 2array "s" execute-string ]
- [ group-read? read>string ]
- [ group-write? write>string ]
- [ [ gid? ] [ group-execute? ] bi 2array "s" execute-string ]
- [ other-read? read>string ]
- [ other-write? write>string ]
- [ [ sticky? ] [ other-execute? ] bi 2array "t" execute-string ]
- } <arr> concat ;
-
-M: unix ls ( path -- lines )
- [ [
- dup file-info
- {
- [ permissions-string ]
- [ nlink>> number>string 3 CHAR: \s pad-left ]
- ! [ uid>> ]
- ! [ gid>> ]
- [ size>> number>string 15 CHAR: \s pad-left ]
- [ modified>> ls-timestamp ]
- } <arr> swap suffix " " join
- ] map
- ] with-group-cache ] with-user-cache ;
\ No newline at end of file
diff --git a/extra/ls/windows/authors.txt b/extra/ls/windows/authors.txt
deleted file mode 100755
index 7c1b2f2279..0000000000
--- a/extra/ls/windows/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Doug Coleman
diff --git a/extra/ls/windows/tags.txt b/extra/ls/windows/tags.txt
deleted file mode 100644
index 6bf68304bb..0000000000
--- a/extra/ls/windows/tags.txt
+++ /dev/null
@@ -1 +0,0 @@
-unportable
diff --git a/extra/ls/windows/windows.factor b/extra/ls/windows/windows.factor
deleted file mode 100755
index b7d7eeeb0b..0000000000
--- a/extra/ls/windows/windows.factor
+++ /dev/null
@@ -1,20 +0,0 @@
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors calendar.format combinators combinators.cleave
-io.files kernel math.parser sequences splitting system ls sequences.lib ;
-IN: ls.windows
-
-: directory-or-size ( file-info -- str )
- dup directory? [
- drop "<DIR>" 20 CHAR: \s pad-right
- ] [
- size>> number>string 20 CHAR: \s pad-left
- ] if ;
-
-M: windows (directory.) ( entries -- lines )
- [
- dup file-info {
- [ modified>> timestamp>ymdhms " " split1 " " splice ]
- [ directory-or-size ]
- } <arr> swap suffix " " join
- ] map ;
\ No newline at end of file
From dffbb120a317184358135d2696a5d4b51db9a184 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 14 Nov 2008 00:39:28 -0600
Subject: [PATCH 081/157] SLOT: now defines the accessor words instead of just
deferring them
---
core/slots/slots-tests.factor | 17 ++++++++++++++++-
core/slots/slots.factor | 20 ++++++++++----------
2 files changed, 26 insertions(+), 11 deletions(-)
diff --git a/core/slots/slots-tests.factor b/core/slots/slots-tests.factor
index 4f4a0cadad..767cec4830 100644
--- a/core/slots/slots-tests.factor
+++ b/core/slots/slots-tests.factor
@@ -1,6 +1,6 @@
IN: slots.tests
USING: math accessors slots strings generic.standard kernel
-tools.test generic words parser eval ;
+tools.test generic words parser eval math.functions ;
TUPLE: r/w-test foo ;
@@ -34,3 +34,18 @@ TUPLE: hello length ;
[ f ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test
[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
+
+! Test protocol slots
+SLOT: my-protocol-slot-test
+
+TUPLE: protocol-slot-test-tuple x ;
+
+M: protocol-slot-test-tuple my-protocol-slot-test>> x>> sq ;
+M: protocol-slot-test-tuple (>>my-protocol-slot-test) [ sqrt ] dip (>>x) ;
+
+[ 9 ] [ T{ protocol-slot-test-tuple { x 3 } } my-protocol-slot-test>> ] unit-test
+
+[ 4.0 ] [
+ T{ protocol-slot-test-tuple { x 3 } } clone
+ [ 7 + ] change-my-protocol-slot-test x>>
+] unit-test
diff --git a/core/slots/slots.factor b/core/slots/slots.factor
index d4ae60ca94..72c79928cb 100644
--- a/core/slots/slots.factor
+++ b/core/slots/slots.factor
@@ -97,16 +97,16 @@ ERROR: bad-slot-value value class ;
: setter-word ( name -- word )
">>" prepend (( object value -- object )) create-accessor ;
-: define-setter ( slot-spec -- )
- name>> dup setter-word dup deferred? [
+: define-setter ( name -- )
+ dup setter-word dup deferred? [
[ \ over , swap writer-word , ] [ ] make define-inline
] [ 2drop ] if ;
: changer-word ( name -- word )
"change-" prepend (( object quot -- object )) create-accessor ;
-: define-changer ( slot-spec -- )
- name>> dup changer-word dup deferred? [
+: define-changer ( name -- )
+ dup changer-word dup deferred? [
[
[ over >r >r ] %
over reader-word ,
@@ -119,8 +119,8 @@ ERROR: bad-slot-value value class ;
[ define-reader ]
[
dup read-only>> [ 2drop ] [
- [ define-setter drop ]
- [ define-changer drop ]
+ [ name>> define-setter drop ]
+ [ name>> define-changer drop ]
[ define-writer ]
2tri
] if
@@ -131,10 +131,10 @@ ERROR: bad-slot-value value class ;
: define-protocol-slot ( name -- )
{
- [ reader-word drop ]
- [ writer-word drop ]
- [ setter-word drop ]
- [ changer-word drop ]
+ [ reader-word define-simple-generic ]
+ [ writer-word define-simple-generic ]
+ [ define-setter ]
+ [ define-changer ]
} cleave ;
ERROR: no-initial-value class ;
From 867669f208c2ab155692e345efc78c8092dc7adc Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Fri, 14 Nov 2008 00:44:01 -0600
Subject: [PATCH 082/157] fix listing on unix
---
basis/io/files/listing/listing.factor | 6 +-----
basis/io/files/listing/unix/unix.factor | 18 ++++++++++--------
2 files changed, 11 insertions(+), 13 deletions(-)
diff --git a/basis/io/files/listing/listing.factor b/basis/io/files/listing/listing.factor
index 314010b75d..a740b2b7be 100755
--- a/basis/io/files/listing/listing.factor
+++ b/basis/io/files/listing/listing.factor
@@ -22,11 +22,7 @@ IN: io.files.listing
: write>string ( ? -- string ) "w" "-" ? ; inline
-HOOK: execute>string os ( ? -- string )
-
-M: object execute>string ( ? -- string ) "x" "-" ? ; inline
-
-HOOK: permissions-string os ( -- str )
+: execute>string ( ? -- string ) "x" "-" ? ; inline
HOOK: (directory.) os ( path -- lines )
diff --git a/basis/io/files/listing/unix/unix.factor b/basis/io/files/listing/unix/unix.factor
index c7f25f001b..f024b1238e 100755
--- a/basis/io/files/listing/unix/unix.factor
+++ b/basis/io/files/listing/unix/unix.factor
@@ -1,10 +1,11 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators kernel system unicode.case
-io.unix.files io.files.listing generalizations ;
+io.unix.files io.files.listing generalizations strings
+arrays sequences io.files math.parser unix.groups unix.users ;
IN: io.files.listing.unix
-M: unix execute-string ( str bools -- str' )
+: unix-execute>string ( str bools -- str' )
swap {
{ { t t } [ >lower ] }
{ { t f } [ >upper ] }
@@ -12,22 +13,23 @@ M: unix execute-string ( str bools -- str' )
[ 2drop "-" ]
} case ;
-M: unix permissions-string ( permissions -- str )
+: permissions-string ( permissions -- str )
{
[ type>> file-type>ch 1string ]
[ user-read? read>string ]
[ user-write? write>string ]
- [ [ uid? ] [ user-execute? ] bi 2array "s" execute-string ]
+ [ [ uid? ] [ user-execute? ] bi 2array "s" unix-execute>string ]
[ group-read? read>string ]
[ group-write? write>string ]
- [ [ gid? ] [ group-execute? ] bi 2array "s" execute-string ]
+ [ [ gid? ] [ group-execute? ] bi 2array "s" unix-execute>string ]
[ other-read? read>string ]
[ other-write? write>string ]
- [ [ sticky? ] [ other-execute? ] bi 2array "t" execute-string ]
+ [ [ sticky? ] [ other-execute? ] bi 2array "t" unix-execute>string ]
} cleave 10 narray concat ;
-M: unix ls ( path -- lines )
- [ [
+M: unix (directory.) ( path -- lines )
+ [ [
+ [
dup file-info
{
[ permissions-string ]
From 7b5f7f95fb3494eac206404240982f0378ae42b3 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Fri, 14 Nov 2008 00:51:14 -0600
Subject: [PATCH 083/157] make more words private
---
basis/io/files/listing/listing.factor | 4 ++++
basis/io/files/listing/unix/unix.factor | 4 ++++
basis/io/files/listing/windows/windows.factor | 4 ++++
3 files changed, 12 insertions(+)
diff --git a/basis/io/files/listing/listing.factor b/basis/io/files/listing/listing.factor
index a740b2b7be..f88fcec3a1 100755
--- a/basis/io/files/listing/listing.factor
+++ b/basis/io/files/listing/listing.factor
@@ -5,6 +5,8 @@ math.parser sequences system vocabs.loader calendar ;
IN: io.files.listing
+<PRIVATE
+
: ls-time ( timestamp -- string )
[ hour>> ] [ minute>> ] bi
[ number>string 2 CHAR: 0 pad-left ] bi@ ":" swap 3append ;
@@ -26,6 +28,8 @@ IN: io.files.listing
HOOK: (directory.) os ( path -- lines )
+PRIVATE>
+
: directory. ( path -- )
[ (directory.) ] with-directory-files [ print ] each ;
diff --git a/basis/io/files/listing/unix/unix.factor b/basis/io/files/listing/unix/unix.factor
index f024b1238e..77e56f50cf 100755
--- a/basis/io/files/listing/unix/unix.factor
+++ b/basis/io/files/listing/unix/unix.factor
@@ -5,6 +5,8 @@ io.unix.files io.files.listing generalizations strings
arrays sequences io.files math.parser unix.groups unix.users ;
IN: io.files.listing.unix
+<PRIVATE
+
: unix-execute>string ( str bools -- str' )
swap {
{ { t t } [ >lower ] }
@@ -41,3 +43,5 @@ M: unix (directory.) ( path -- lines )
} cleave 4 narray swap suffix " " join
] map
] with-group-cache ] with-user-cache ;
+
+PRIVATE>
diff --git a/basis/io/files/listing/windows/windows.factor b/basis/io/files/listing/windows/windows.factor
index 53481fc7f8..7c108780dc 100755
--- a/basis/io/files/listing/windows/windows.factor
+++ b/basis/io/files/listing/windows/windows.factor
@@ -5,6 +5,8 @@ kernel math.parser sequences splitting system io.files.listing
generalizations ;
IN: io.files.listing.windows
+<PRIVATE
+
: directory-or-size ( file-info -- str )
dup directory? [
drop "<DIR>" 20 CHAR: \s pad-right
@@ -19,3 +21,5 @@ M: windows (directory.) ( entries -- lines )
[ directory-or-size ]
} cleave 2 narray swap suffix " " join
] map ;
+
+PRIVATE>
From 7bb5ab8752c479e01dc5996fead9d377fa3a930b Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Fri, 14 Nov 2008 00:55:17 -0600
Subject: [PATCH 084/157] fix load error, document directory.
---
basis/io/files/listing/listing-docs.factor | 17 +++++++++++++++++
basis/io/files/listing/unix/unix.factor | 3 ++-
basis/io/files/listing/windows/windows.factor | 2 +-
3 files changed, 20 insertions(+), 2 deletions(-)
create mode 100644 basis/io/files/listing/listing-docs.factor
diff --git a/basis/io/files/listing/listing-docs.factor b/basis/io/files/listing/listing-docs.factor
new file mode 100644
index 0000000000..6b19e9bfa7
--- /dev/null
+++ b/basis/io/files/listing/listing-docs.factor
@@ -0,0 +1,17 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io.streams.string strings ;
+IN: io.files.listing
+
+HELP: directory.
+{ $values
+ { "path" "a pathname string" }
+}
+{ $description "Prints information about all files in a directory to the output stream in a cross-platform way similar to the Unix " { $snippet "ls" } " command." } ;
+
+ARTICLE: "io.files.listing" "Listing files"
+"The " { $vocab-link "io.files.listing" } " vocabulary implements directory file listing in a cross-platform way." $nl
+"Listing a directory:"
+{ $subsection directory. } ;
+
+ABOUT: "io.files.listing"
diff --git a/basis/io/files/listing/unix/unix.factor b/basis/io/files/listing/unix/unix.factor
index 77e56f50cf..313ce1f79a 100755
--- a/basis/io/files/listing/unix/unix.factor
+++ b/basis/io/files/listing/unix/unix.factor
@@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators kernel system unicode.case
io.unix.files io.files.listing generalizations strings
-arrays sequences io.files math.parser unix.groups unix.users ;
+arrays sequences io.files math.parser unix.groups unix.users
+io.files.listing.private ;
IN: io.files.listing.unix
<PRIVATE
diff --git a/basis/io/files/listing/windows/windows.factor b/basis/io/files/listing/windows/windows.factor
index 7c108780dc..33ab47a50a 100755
--- a/basis/io/files/listing/windows/windows.factor
+++ b/basis/io/files/listing/windows/windows.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors calendar.format combinators io.files
kernel math.parser sequences splitting system io.files.listing
-generalizations ;
+generalizations io.files.listing.private ;
IN: io.files.listing.windows
<PRIVATE
From 6f60d897c5b7d04977b13553b0f3c9a8ff509119 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Fri, 14 Nov 2008 02:56:12 -0600
Subject: [PATCH 085/157] cleanup of ftp.client. remove the ls load error.
---
extra/ftp/client/client.factor | 162 ++++++------------
extra/ftp/client/listing-parser/authors.txt | 1 +
.../listing-parser/listing-parser.factor | 89 ++++++++++
extra/ftp/ftp.factor | 19 +-
extra/ftp/server/server.factor | 10 +-
5 files changed, 151 insertions(+), 130 deletions(-)
create mode 100644 extra/ftp/client/listing-parser/authors.txt
create mode 100644 extra/ftp/client/listing-parser/listing-parser.factor
diff --git a/extra/ftp/client/client.factor b/extra/ftp/client/client.factor
index 9251e1aa55..9c82cdbb50 100644
--- a/extra/ftp/client/client.factor
+++ b/extra/ftp/client/client.factor
@@ -2,8 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays classes.singleton combinators
continuations io io.encodings.binary io.encodings.utf8
-io.files io.sockets kernel io.streams.duplex math ls
-math.parser sequences splitting namespaces strings fry ftp ;
+io.files io.sockets kernel io.streams.duplex math
+math.parser sequences splitting namespaces strings fry ftp
+ftp.client.listing-parser urls ;
IN: ftp.client
: (ftp-response-code) ( str -- n )
@@ -24,145 +25,86 @@ IN: ftp.client
[ fourth CHAR: - = ] tri
[ read-response-loop ] when ;
+ERROR: ftp-error got expected ;
+
+: ftp-assert ( ftp-response n -- )
+ 2dup [ n>> ] dip = [ 2drop ] [ ftp-error ] if ;
+
: ftp-command ( string -- ftp-response )
ftp-send read-response ;
-: ftp-user ( ftp-client -- ftp-response )
- user>> "USER " prepend ftp-command ;
+: ftp-user ( url -- ftp-response )
+ username>> "USER " prepend ftp-command ;
-: ftp-password ( ftp-client -- ftp-response )
+: ftp-password ( url -- ftp-response )
password>> "PASS " prepend ftp-command ;
-: ftp-set-binary ( -- ftp-response )
- "TYPE I" ftp-command ;
-
-: ftp-pwd ( -- ftp-response )
- "PWD" ftp-command ;
-
-: ftp-list ( -- ftp-response )
- "LIST" ftp-command ;
-
-: ftp-quit ( -- ftp-response )
- "QUIT" ftp-command ;
-
: ftp-cwd ( directory -- ftp-response )
"CWD " prepend ftp-command ;
: ftp-retr ( filename -- ftp-response )
"RETR " prepend ftp-command ;
-: parse-epsv ( ftp-response -- port )
- strings>> first
- "|" split 2 tail* first string>number ;
+: ftp-set-binary ( -- ftp-response ) "TYPE I" ftp-command ;
-TUPLE: remote-file
-type permissions links owner group size month day time year
-name target ;
+: ftp-pwd ( -- ftp-response ) "PWD" ftp-command ;
-: <remote-file> ( -- remote-file ) remote-file new ;
+: ftp-list ( -- )
+ "LIST" ftp-command 150 ftp-assert ;
-: parse-permissions ( remote-file str -- remote-file )
- [ first ch>type >>type ] [ rest >>permissions ] bi ;
-
-: parse-list-11 ( lines -- seq )
- [
- 11 f pad-right
- <remote-file> swap {
- [ 0 swap nth parse-permissions ]
- [ 1 swap nth string>number >>links ]
- [ 2 swap nth >>owner ]
- [ 3 swap nth >>group ]
- [ 4 swap nth string>number >>size ]
- [ 5 swap nth >>month ]
- [ 6 swap nth >>day ]
- [ 7 swap nth >>time ]
- [ 8 swap nth >>name ]
- [ 10 swap nth >>target ]
- } cleave
- ] map ;
-
-: parse-list-8 ( lines -- seq )
- [
- <remote-file> swap {
- [ 0 swap nth parse-permissions ]
- [ 1 swap nth string>number >>links ]
- [ 2 swap nth >>owner ]
- [ 3 swap nth >>size ]
- [ 4 swap nth >>month ]
- [ 5 swap nth >>day ]
- [ 6 swap nth >>time ]
- [ 7 swap nth >>name ]
- } cleave
- ] map ;
-
-: parse-list-3 ( lines -- seq )
- [
- <remote-file> swap {
- [ 0 swap nth parse-permissions ]
- [ 1 swap nth string>number >>links ]
- [ 2 swap nth >>name ]
- } cleave
- ] map ;
-
-: parse-list ( ftp-response -- ftp-response )
- dup strings>>
- [ " " split harvest ] map
- dup length {
- { 11 [ parse-list-11 ] }
- { 9 [ parse-list-11 ] }
- { 8 [ parse-list-8 ] }
- { 3 [ parse-list-3 ] }
- [ drop ]
- } case >>parsed ;
+: ftp-quit ( -- ftp-response ) "QUIT" ftp-command ;
: ftp-epsv ( -- ftp-response )
- "EPSV" ftp-command ;
+ "EPSV" ftp-command dup 229 ftp-assert ;
-ERROR: ftp-error got expected ;
-: ftp-assert ( ftp-response n -- )
- 2dup [ n>> ] dip = [ 2drop ] [ ftp-error ] if ;
+: parse-epsv ( ftp-response -- port )
+ strings>> first "|" split 2 tail* first string>number ;
-: ftp-login ( ftp-client -- )
- read-response 220 ftp-assert
- [ ftp-user 331 ftp-assert ]
- [ ftp-password 230 ftp-assert ] bi
- ftp-set-binary 200 ftp-assert ;
+: open-passive-client ( url protocol -- stream )
+ [ host>> ftp-epsv parse-epsv <inet> ] dip <client> drop ;
-: open-remote-port ( -- port )
- ftp-epsv
- [ 229 ftp-assert ] [ parse-epsv ] bi ;
-
-: list ( ftp-client -- ftp-response )
- host>> open-remote-port <inet> utf8 <client> drop
- ftp-list 150 ftp-assert
+: list ( url -- ftp-response )
+ utf8 open-passive-client
+ ftp-list
lines
<ftp-response> swap >>strings
read-response 226 ftp-assert
parse-list ;
-: ftp-get ( filename ftp-client -- ftp-response )
- host>> open-remote-port <inet> binary <client> drop
- swap
+: (ftp-get) ( url path -- )
+ [ binary open-passive-client ] dip
[ ftp-retr 150 ftp-assert drop ]
[ binary <file-writer> stream-copy ] 2bi
- read-response dup 226 ftp-assert ;
+ read-response 226 ftp-assert ;
-: ftp-connect ( ftp-client -- stream )
+: ftp-login ( url -- )
+ read-response 220 ftp-assert
+ [ ftp-user 331 ftp-assert ]
+ [ ftp-password 230 ftp-assert ] bi
+ ftp-set-binary 200 ftp-assert ;
+
+: ftp-connect ( url -- stream )
[ host>> ] [ port>> ] bi <inet> utf8 <client> drop ;
-GENERIC: ftp-download ( path obj -- )
+: with-ftp-client ( url quot -- )
+ [ [ ftp-connect ] keep ] dip
+ '[ _ [ ftp-login ] _ bi ftp-quit drop ] with-stream ; inline
-: with-ftp-client ( ftp-client quot -- )
- dupd '[
- _ [ ftp-login ] [ @ ] bi
- ftp-quit drop
- ] [ ftp-connect ] dip with-stream ; inline
+: ensure-login ( url -- url )
+ dup username>> [
+ "anonymous" >>username
+ "ftp-client" >>password
+ ] unless ;
-M: ftp-client ftp-download ( path ftp-client -- )
- [
- [ drop parent-directory ftp-cwd drop ]
- [ [ file-name ] dip ftp-get drop ] 2bi
+: >ftp-url ( url -- url' ) >url ensure-port ensure-login ;
+
+: ftp-get ( url -- )
+ >ftp-url [
+ dup path>>
+ [ nip parent-directory ftp-cwd drop ]
+ [ file-name (ftp-get) ] 2bi
] with-ftp-client ;
-M: string ftp-download ( path string -- )
- <ftp-client> ftp-download ;
+
+
+
diff --git a/extra/ftp/client/listing-parser/authors.txt b/extra/ftp/client/listing-parser/authors.txt
new file mode 100644
index 0000000000..b4bd0e7b35
--- /dev/null
+++ b/extra/ftp/client/listing-parser/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
\ No newline at end of file
diff --git a/extra/ftp/client/listing-parser/listing-parser.factor b/extra/ftp/client/listing-parser/listing-parser.factor
new file mode 100644
index 0000000000..04e96ed77a
--- /dev/null
+++ b/extra/ftp/client/listing-parser/listing-parser.factor
@@ -0,0 +1,89 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators io.files kernel math.parser
+sequences splitting ;
+IN: ftp.client.listing-parser
+
+: ch>file-type ( ch -- type )
+ {
+ { CHAR: b [ +block-device+ ] }
+ { CHAR: c [ +character-device+ ] }
+ { CHAR: d [ +directory+ ] }
+ { CHAR: l [ +symbolic-link+ ] }
+ { CHAR: s [ +socket+ ] }
+ { CHAR: p [ +fifo+ ] }
+ { CHAR: - [ +regular-file+ ] }
+ [ drop +unknown+ ]
+ } case ;
+
+: file-type>ch ( type -- string )
+ {
+ { +block-device+ [ CHAR: b ] }
+ { +character-device+ [ CHAR: c ] }
+ { +directory+ [ CHAR: d ] }
+ { +symbolic-link+ [ CHAR: l ] }
+ { +socket+ [ CHAR: s ] }
+ { +fifo+ [ CHAR: p ] }
+ { +regular-file+ [ CHAR: - ] }
+ [ drop CHAR: - ]
+ } case ;
+
+: parse-permissions ( remote-file str -- remote-file )
+ [ first ch>file-type >>type ] [ rest >>permissions ] bi ;
+
+TUPLE: remote-file
+type permissions links owner group size month day time year
+name target ;
+
+: <remote-file> ( -- remote-file ) remote-file new ;
+
+: parse-list-11 ( lines -- seq )
+ [
+ 11 f pad-right
+ <remote-file> swap {
+ [ 0 swap nth parse-permissions ]
+ [ 1 swap nth string>number >>links ]
+ [ 2 swap nth >>owner ]
+ [ 3 swap nth >>group ]
+ [ 4 swap nth string>number >>size ]
+ [ 5 swap nth >>month ]
+ [ 6 swap nth >>day ]
+ [ 7 swap nth >>time ]
+ [ 8 swap nth >>name ]
+ [ 10 swap nth >>target ]
+ } cleave
+ ] map ;
+
+: parse-list-8 ( lines -- seq )
+ [
+ <remote-file> swap {
+ [ 0 swap nth parse-permissions ]
+ [ 1 swap nth string>number >>links ]
+ [ 2 swap nth >>owner ]
+ [ 3 swap nth >>size ]
+ [ 4 swap nth >>month ]
+ [ 5 swap nth >>day ]
+ [ 6 swap nth >>time ]
+ [ 7 swap nth >>name ]
+ } cleave
+ ] map ;
+
+: parse-list-3 ( lines -- seq )
+ [
+ <remote-file> swap {
+ [ 0 swap nth parse-permissions ]
+ [ 1 swap nth string>number >>links ]
+ [ 2 swap nth >>name ]
+ } cleave
+ ] map ;
+
+: parse-list ( ftp-response -- ftp-response )
+ dup strings>>
+ [ " " split harvest ] map
+ dup length {
+ { 11 [ parse-list-11 ] }
+ { 9 [ parse-list-11 ] }
+ { 8 [ parse-list-8 ] }
+ { 3 [ parse-list-3 ] }
+ [ drop ]
+ } case >>parsed ;
diff --git a/extra/ftp/ftp.factor b/extra/ftp/ftp.factor
index e396e36180..adf7d5b41b 100644
--- a/extra/ftp/ftp.factor
+++ b/extra/ftp/ftp.factor
@@ -1,27 +1,12 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators io io.files kernel
-math.parser sequences strings ls ;
+math.parser sequences strings ;
IN: ftp
SINGLETON: active
SINGLETON: passive
-TUPLE: ftp-client host port user password mode state
-command-promise ;
-
-: <ftp-client> ( host -- ftp-client )
- ftp-client new
- swap >>host
- 21 >>port
- "anonymous" >>user
- "ftp@my.org" >>password ;
-
-: reset-ftp-client ( ftp-client -- )
- f >>user
- f >>password
- drop ;
-
TUPLE: ftp-response n strings parsed ;
: <ftp-response> ( -- ftp-response )
@@ -34,5 +19,3 @@ TUPLE: ftp-response n strings parsed ;
: ftp-send ( string -- ) write "\r\n" write flush ;
: ftp-ipv4 1 ; inline
: ftp-ipv6 2 ; inline
-
-: directory-list ( -- seq ) "" ls ;
diff --git a/extra/ftp/server/server.factor b/extra/ftp/server/server.factor
index e40af2afbe..f8ab04ed00 100644
--- a/extra/ftp/server/server.factor
+++ b/extra/ftp/server/server.factor
@@ -7,9 +7,15 @@ namespaces make sequences ftp io.unix.launcher.parser
unicode.case splitting assocs classes io.servers.connection
destructors calendar io.timeouts io.streams.duplex threads
continuations math concurrency.promises byte-arrays
-io.backend sequences.lib tools.hexdump ;
+io.backend sequences.lib tools.hexdump io.files.listing ;
IN: ftp.server
+TUPLE: ftp-client url mode state command-promise ;
+
+: <ftp-client> ( url -- ftp-client )
+ ftp-client new
+ swap >>url ;
+
SYMBOL: client
: ftp-server-directory ( -- str )
@@ -143,7 +149,7 @@ M: ftp-list service-command ( stream obj -- )
start-directory
[
utf8 encode-output
- directory-list [ ftp-send ] each
+ directory. [ ftp-send ] each
] with-output-stream
finish-directory ;
From 615c380015c5afe512788ce21c08bbcf350fd1a7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 14 Nov 2008 04:01:26 -0600
Subject: [PATCH 086/157] Working on docs for furnace.json,
furnace.redirection, and furnace.referrer
---
.../boilerplate/boilerplate-docs.factor | 27 +++
basis/furnace/furnace-docs.factor | 189 ++++++++++++++++++
basis/furnace/furnace.factor | 23 +++
basis/furnace/json/json-docs.factor | 2 +-
.../redirection/redirection-docs.factor | 58 ++++++
basis/furnace/referrer/referrer-docs.factor | 15 ++
.../syndication/syndication-docs.factor | 69 +++++++
7 files changed, 382 insertions(+), 1 deletion(-)
create mode 100644 basis/furnace/boilerplate/boilerplate-docs.factor
create mode 100644 basis/furnace/furnace-docs.factor
create mode 100644 basis/furnace/redirection/redirection-docs.factor
create mode 100644 basis/furnace/referrer/referrer-docs.factor
create mode 100644 basis/furnace/syndication/syndication-docs.factor
diff --git a/basis/furnace/boilerplate/boilerplate-docs.factor b/basis/furnace/boilerplate/boilerplate-docs.factor
new file mode 100644
index 0000000000..5594928082
--- /dev/null
+++ b/basis/furnace/boilerplate/boilerplate-docs.factor
@@ -0,0 +1,27 @@
+! Copyright (C) 2008 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io.streams.string ;
+IN: furnace.boilerplate
+
+HELP: <boilerplate>
+{ $values
+ { "responder" null }
+ { "boilerplate" null }
+}
+{ $description "" } ;
+
+HELP: boilerplate
+{ $description "" } ;
+
+HELP: wrap-boilerplate?
+{ $values
+ { "response" null }
+ { "?" "a boolean" }
+}
+{ $description "" } ;
+
+ARTICLE: "furnace.boilerplate" "Furnace boilerplate support"
+{ $vocab-link "furnace.boilerplate" }
+;
+
+ABOUT: "furnace.boilerplate"
diff --git a/basis/furnace/furnace-docs.factor b/basis/furnace/furnace-docs.factor
new file mode 100644
index 0000000000..0e2e6c1f40
--- /dev/null
+++ b/basis/furnace/furnace-docs.factor
@@ -0,0 +1,189 @@
+USING: assocs help.markup help.syntax io.streams.string quotations sequences strings urls ;
+IN: furnace
+
+HELP: adjust-redirect-url
+{ $values
+ { "url" url }
+ { "url'" url }
+}
+{ $description "" } ;
+
+HELP: adjust-url
+{ $values
+ { "url" url }
+ { "url'" url }
+}
+{ $description "" } ;
+
+HELP: base-path
+{ $values
+ { "string" string }
+ { "pair" null }
+}
+{ $description "" } ;
+
+HELP: client-state
+{ $values
+ { "key" null }
+ { "value/f" null }
+}
+{ $description "" } ;
+
+HELP: cookie-client-state
+{ $values
+ { "key" null } { "request" null }
+ { "value/f" null }
+}
+{ $description "" } ;
+
+HELP: each-responder
+{ $values
+ { "quot" quotation }
+}
+{ $description "" } ;
+
+HELP: exit-continuation
+{ $description "" } ;
+
+HELP: exit-with
+{ $values
+ { "value" null }
+}
+{ $description "" } ;
+
+HELP: hidden-form-field
+{ $values
+ { "value" null } { "name" null }
+}
+{ $description "" } ;
+
+HELP: link-attr
+{ $values
+ { "tag" null } { "responder" null }
+}
+{ $description "" } ;
+
+HELP: modify-form
+{ $values
+ { "responder" null }
+}
+{ $description "" } ;
+
+HELP: modify-query
+{ $values
+ { "query" null } { "responder" null }
+ { "query'" null }
+}
+{ $description "" } ;
+
+HELP: modify-redirect-query
+{ $values
+ { "query" null } { "responder" null }
+ { "query'" null }
+}
+{ $description "" } ;
+
+HELP: nested-forms-key
+{ $description "" } ;
+
+HELP: nested-responders
+{ $values
+
+ { "seq" sequence }
+}
+{ $description "" } ;
+
+HELP: post-client-state
+{ $values
+ { "key" null } { "request" null }
+ { "value/f" null }
+}
+{ $description "" } ;
+
+HELP: referrer
+{ $values
+
+ { "referrer/f" null }
+}
+{ $description "" } ;
+
+HELP: request-params
+{ $values
+ { "request" null }
+ { "assoc" assoc }
+}
+{ $description "" } ;
+
+HELP: resolve-base-path
+{ $values
+ { "string" string }
+ { "string'" string }
+}
+{ $description "" } ;
+
+HELP: resolve-template-path
+{ $values
+ { "pair" null }
+ { "path" "a pathname string" }
+}
+{ $description "" } ;
+
+HELP: same-host?
+{ $values
+ { "url" url }
+ { "?" "a boolean" }
+}
+{ $description "" } ;
+
+HELP: user-agent
+{ $values
+
+ { "user-agent" null }
+}
+{ $description "" } ;
+
+HELP: vocab-path
+{ $values
+ { "vocab" "a vocabulary specifier" }
+ { "path" "a pathname string" }
+}
+{ $description "" } ;
+
+HELP: with-exit-continuation
+{ $values
+ { "quot" quotation }
+}
+{ $description "" } ;
+
+ARTICLE: "furnace" "Furnace web framework"
+"The " { $vocab-link "furnace" } " vocabulary implements a full-featured web framework on top of the " { $link "http.server" } ". Some of its features include:"
+{ $list
+ "Session management capable of load-balancing and fail-over"
+ "Form components and validation"
+ "Authentication system with basic authentication or login pages, and pluggable authentication backends"
+ "Easy Atom feed syndication"
+ "Conversation scope and asides for complex page flow"
+}
+"Major functionality:"
+{ $subsection "furnace.actions" }
+{ $subsection "furnace.syndication" }
+{ $subsection "furnace.boilerplate" }
+{ $subsection "furnace.db" }
+"Server-side state:"
+{ $subsection "furnace.sessions" }
+{ $subsection "furnace.conversations" }
+{ $subsection "furnace.asides" }
+"HTML components:"
+{ $subsection "html.components" }
+{ $subsection "html.forms" }
+"Content templates:"
+{ $subsection "html.templates" }
+{ $subsection "html.templates.chloe" }
+{ $subsection "html.templates.fhtml" }
+"Utilities:"
+{ $subsection "furnace.alloy" }
+{ $subsection "furnace.json" }
+{ $subsection "furnace.redirection" }
+{ $subsection "furnace.referrer" } ;
+
+ABOUT: "furnace"
diff --git a/basis/furnace/furnace.factor b/basis/furnace/furnace.factor
index 7285c436bc..a77b0d28c7 100644
--- a/basis/furnace/furnace.factor
+++ b/basis/furnace/furnace.factor
@@ -128,4 +128,27 @@ SYMBOL: exit-continuation
: with-exit-continuation ( quot -- )
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
+USE: vocabs.loader
+"furnace.actions" require
+"furnace.alloy" require
+"furnace.asides" require
+"furnace.auth" require
+"furnace.auth.basic" require
+"furnace.auth.features.deactivate-user" require
+"furnace.auth.features.edit-profile" require
+"furnace.auth.features.recover-password" require
+"furnace.auth.features.registration" require
+"furnace.auth.login" require
+"furnace.auth.providers.assoc" require
+"furnace.auth.providers.db" require
+"furnace.auth.providers.null" require
+"furnace.boilerplate" require
"furnace.chloe-tags" require
+"furnace.conversations" require
+"furnace.db" require
+"furnace.json" require
+"furnace.redirection" require
+"furnace.referrer" require
+"furnace.scopes" require
+"furnace.sessions" require
+"furnace.syndication" require
diff --git a/basis/furnace/json/json-docs.factor b/basis/furnace/json/json-docs.factor
index daa84e9295..c20c2e6c91 100644
--- a/basis/furnace/json/json-docs.factor
+++ b/basis/furnace/json/json-docs.factor
@@ -1,4 +1,4 @@
-USING: kernel http.server help.markup help.syntax ;
+USING: kernel http.server help.markup help.syntax http ;
IN: furnace.json
HELP: <json-content>
diff --git a/basis/furnace/redirection/redirection-docs.factor b/basis/furnace/redirection/redirection-docs.factor
new file mode 100644
index 0000000000..42fd3a1f2a
--- /dev/null
+++ b/basis/furnace/redirection/redirection-docs.factor
@@ -0,0 +1,58 @@
+USING: help.markup help.syntax io.streams.string quotations urls
+http.server http ;
+IN: furnace.redirection
+
+HELP: <redirect-responder>
+{ $values { "url" url } { "responder" "a responder" } }
+{ $description "Creates a responder which unconditionally redirects the client to the given URL." } ;
+
+HELP: <redirect>
+{ $values { "url" url } { "response" response } }
+{ $description "Creates a response which redirects the client to the given URL." } ;
+
+HELP: <secure-only> ( responder -- responder' )
+{ $description "Creates a new responder which ensures that the client is connecting via HTTPS before delegating to the underlying responder. If the client is connecting via HTTP, a redirect is sent instead." } ;
+
+HELP: <secure-redirect>
+{ $values
+ { "url" url }
+ { "response" response }
+}
+{ $description "Creates a responder which unconditionally redirects the client to the given URL after setting its protocol to HTTPS." }
+{ $notes "This word is intended to be used with a relative URL. The client is redirected to the relative URL, but with HTTPS instead of HTTP." } ;
+
+HELP: >secure-url
+{ $values
+ { "url" url }
+ { "url'" url }
+}
+{ $description "Sets the protocol of a URL to HTTPS." } ;
+
+HELP: if-secure
+{ $values
+ { "quot" quotation }
+ { "response" response }
+}
+{ $description "Runs a quotation if the current request was made over HTTPS, otherwise returns a redirect to have the client request the current page again via HTTPS." } ;
+
+ARTICLE: "furnace.redirection.secure" "Secure redirection"
+"The words in this section help with implementing sites which require SSL/TLS for additional security."
+$nl
+"Converting a HTTP URL into an HTTPS URL:"
+{ $subsection >secure-url }
+"Redirecting the client to an HTTPS URL:"
+{ $subsection <secure-redirect> }
+"Tools for writing responders which require SSL/TLS connections:"
+{ $subsection if-secure }
+{ $subsection <secure-only> } ;
+
+ARTICLE: "furnace.redirection" "Furnace redirection support"
+"The " { $vocab-link "furnace.redirection" } " vocabulary builds additional functionality on top of " { $vocab-link "http.server.redirection" } ", and integrates with various Furnace features such as " { $link "furnace.asides" } " and " { $link "furnace.conversations" } "."
+$nl
+"A redirection response which takes asides and conversations into account:"
+{ $subsection <redirect> }
+"A responder which unconditionally redirects the client to another URL:"
+{ $subsection <redirect-responder> }
+{ $subsection "furnace.redirection.secure" } ;
+
+ABOUT: "furnace.redirection"
diff --git a/basis/furnace/referrer/referrer-docs.factor b/basis/furnace/referrer/referrer-docs.factor
new file mode 100644
index 0000000000..5deebbe9a7
--- /dev/null
+++ b/basis/furnace/referrer/referrer-docs.factor
@@ -0,0 +1,15 @@
+USING: help.markup help.syntax io.streams.string ;
+IN: furnace.referrer
+
+HELP: <check-form-submissions>
+{ $values
+ { "responder" "a responder" }
+ { "responder'" "a responder" }
+}
+{ $description "Wraps the responder in a filter responder which ensures that form submissions originate from a page on the same server. Any submissions which do not are sent back with a 403 error." } ;
+
+ARTICLE: "furnace.referrer" "Form submission referrer checking"
+"The " { $vocab-link "furnace.referrer" } " implements a simple security measure which can be used to thwart cross-site scripting attacks."
+{ $subsection <check-form-submissions> } ;
+
+ABOUT: "furnace.referrer"
diff --git a/basis/furnace/syndication/syndication-docs.factor b/basis/furnace/syndication/syndication-docs.factor
new file mode 100644
index 0000000000..7a9ec57468
--- /dev/null
+++ b/basis/furnace/syndication/syndication-docs.factor
@@ -0,0 +1,69 @@
+! Copyright (C) 2008 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io.streams.string kernel sequences strings urls ;
+IN: furnace.syndication
+
+HELP: <feed-action>
+{ $values
+
+ { "action" null }
+}
+{ $description "" } ;
+
+HELP: <feed-content>
+{ $values
+ { "body" null }
+ { "response" null }
+}
+{ $description "" } ;
+
+HELP: >entry
+{ $values
+ { "object" object }
+ { "entry" null }
+}
+{ $description "" } ;
+
+HELP: feed-action
+{ $description "" } ;
+
+HELP: feed-entry-date
+{ $values
+ { "object" object }
+ { "timestamp" null }
+}
+{ $description "" } ;
+
+HELP: feed-entry-description
+{ $values
+ { "object" object }
+ { "description" null }
+}
+{ $description "" } ;
+
+HELP: feed-entry-title
+{ $values
+ { "object" object }
+ { "string" string }
+}
+{ $description "" } ;
+
+HELP: feed-entry-url
+{ $values
+ { "object" object }
+ { "url" url }
+}
+{ $description "" } ;
+
+HELP: process-entries
+{ $values
+ { "seq" sequence }
+ { "seq'" sequence }
+}
+{ $description "" } ;
+
+ARTICLE: "furnace.syndication" "Furnace Atom syndication support"
+{ $vocab-link "furnace.syndication" }
+;
+
+ABOUT: "furnace.syndication"
From f6010d167250486ef781a0f4aa60f38625594fc7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 14 Nov 2008 04:01:43 -0600
Subject: [PATCH 087/157] Rename alias article
---
basis/alias/alias-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/alias/alias-docs.factor b/basis/alias/alias-docs.factor
index 4dcf1a7738..3f2eee6460 100644
--- a/basis/alias/alias-docs.factor
+++ b/basis/alias/alias-docs.factor
@@ -16,7 +16,7 @@ HELP: ALIAS:
}
} ;
-ARTICLE: "alias" "Alias"
+ARTICLE: "alias" "Word aliasing"
"The " { $vocab-link "alias" } " vocabulary implements a way to make many different names for the same word. Although creating new names for words is generally frowned upon, aliases are useful for the Win32 API and other cases where words need to be renamed for symmetry." $nl
"Make a new word that aliases another word:"
{ $subsection define-alias }
From dd479ffad11aec120f21c7469a8643d3d75e5501 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 14 Nov 2008 07:22:19 -0600
Subject: [PATCH 088/157] Help lint fixes
---
basis/furnace/alloy/alloy-docs.factor | 2 +-
basis/furnace/redirection/redirection-docs.factor | 1 +
2 files changed, 2 insertions(+), 1 deletion(-)
diff --git a/basis/furnace/alloy/alloy-docs.factor b/basis/furnace/alloy/alloy-docs.factor
index d07d534510..f108428c90 100644
--- a/basis/furnace/alloy/alloy-docs.factor
+++ b/basis/furnace/alloy/alloy-docs.factor
@@ -5,7 +5,7 @@ HELP: init-furnace-tables
{ $description "Initializes database tables used by asides, conversations and session management. This word must be invoked inside a " { $link with-db } " scope." } ;
HELP: <alloy>
-{ $values { "responder" "a responder" } { "db" db } { "alloy" "an alloy responder" } }
+{ $values { "responder" "a responder" } { "db" db } { "responder'" "an alloy responder" } }
{ $description "Wraps the responder with support for asides, conversations, sessions and database persistence." }
{ $examples
"The " { $vocab-link "webapps.counter" } " vocabulary uses an alloy to configure the counter:"
diff --git a/basis/furnace/redirection/redirection-docs.factor b/basis/furnace/redirection/redirection-docs.factor
index 42fd3a1f2a..fd3671fa1c 100644
--- a/basis/furnace/redirection/redirection-docs.factor
+++ b/basis/furnace/redirection/redirection-docs.factor
@@ -11,6 +11,7 @@ HELP: <redirect>
{ $description "Creates a response which redirects the client to the given URL." } ;
HELP: <secure-only> ( responder -- responder' )
+{ $values { "responder" "a responder" } { "responder'" "a responder" } }
{ $description "Creates a new responder which ensures that the client is connecting via HTTPS before delegating to the underlying responder. If the client is connecting via HTTP, a redirect is sent instead." } ;
HELP: <secure-redirect>
From ff95802c460e54e140e934e7a6c0c2bf45739984 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 14 Nov 2008 20:17:27 -0600
Subject: [PATCH 089/157] Change tags a bit
---
basis/sorting/human/tags.txt | 1 +
basis/sorting/insertion/tags.txt | 1 +
core/sorting/tags.txt | 1 +
extra/advice/tags.txt | 4 +---
4 files changed, 4 insertions(+), 3 deletions(-)
diff --git a/basis/sorting/human/tags.txt b/basis/sorting/human/tags.txt
index 3ab2d731fe..93a2a0fa14 100644
--- a/basis/sorting/human/tags.txt
+++ b/basis/sorting/human/tags.txt
@@ -1,2 +1,3 @@
collections
text
+algorithms
diff --git a/basis/sorting/insertion/tags.txt b/basis/sorting/insertion/tags.txt
index 42d711b32b..1e3d675068 100644
--- a/basis/sorting/insertion/tags.txt
+++ b/basis/sorting/insertion/tags.txt
@@ -1 +1,2 @@
collections
+algorithms
diff --git a/core/sorting/tags.txt b/core/sorting/tags.txt
index 42d711b32b..1e3d675068 100644
--- a/core/sorting/tags.txt
+++ b/core/sorting/tags.txt
@@ -1 +1,2 @@
collections
+algorithms
diff --git a/extra/advice/tags.txt b/extra/advice/tags.txt
index a87b65d938..f4274299b1 100644
--- a/extra/advice/tags.txt
+++ b/extra/advice/tags.txt
@@ -1,3 +1 @@
-advice
-aspect
-annotations
+extensions
From 9099b126035c99cd146774052fba2d1a534eb351 Mon Sep 17 00:00:00 2001
From: jao <jao@oblong.net>
Date: Sat, 15 Nov 2008 03:52:20 +0100
Subject: [PATCH 090/157] factor.el: fix for empty strings font lock.
---
misc/factor.el | 1 +
1 file changed, 1 insertion(+)
diff --git a/misc/factor.el b/misc/factor.el
index 72fdf64159..2afb5a7b7f 100644
--- a/misc/factor.el
+++ b/misc/factor.el
@@ -103,6 +103,7 @@
(" !.*$" . font-lock-comment-face)
("( .* )" . font-lock-comment-face)
("\"[^ ][^\"]*\"" . font-lock-string-face)
+ ("\"\"" . font-lock-string-face)
("\\(P\\|SBUF\\)\"" 1 font-lock-keyword-face)
,@(mapcar #'(lambda (w) (cons (concat "\\(^\\| \\)\\(" w "\\)\\($\\| \\)")
'(2 font-lock-keyword-face)))
From df3853262424cc7e253ad50674c789a2fb638e16 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 14 Nov 2008 21:21:10 -0600
Subject: [PATCH 091/157] Document furnace.boilerplate
---
basis/furnace/actions/actions-docs.factor | 4 +--
.../boilerplate/boilerplate-docs.factor | 36 ++++++++++++-------
2 files changed, 25 insertions(+), 15 deletions(-)
diff --git a/basis/furnace/actions/actions-docs.factor b/basis/furnace/actions/actions-docs.factor
index 509e0bcdee..dd453ae16d 100644
--- a/basis/furnace/actions/actions-docs.factor
+++ b/basis/furnace/actions/actions-docs.factor
@@ -19,7 +19,7 @@ HELP: <page-action>
{ $description "Creates a new action which serves a Chloe template when servicing a GET request." } ;
HELP: action
-{ $description "The class of Furnace actions. New instances are created with " { $link <action> } ". New instances of subclasses can be created with " { $link new-action } ". The " { $link page-action } " class is a useful subclass."
+{ $class-description "The class of Furnace actions. New instances are created with " { $link <action> } ". New instances of subclasses can be created with " { $link new-action } ". The " { $link page-action } " class is a useful subclass."
$nl
"Action slots are documented in " { $link "furnace.actions.config" } "." } ;
@@ -31,7 +31,7 @@ HELP: new-action
{ $description "Constructs a subclass of " { $link action } "." } ;
HELP: page-action
-{ $description "The class of Chloe page actions. These are actions whose " { $slot "display" } " slot is pre-set to serve the Chloe template stored in the " { $slot "page" } " slot." } ;
+{ $class-description "The class of Chloe page actions. These are actions whose " { $slot "display" } " slot is pre-set to serve the Chloe template stored in the " { $slot "page" } " slot." } ;
HELP: param
{ $values
diff --git a/basis/furnace/boilerplate/boilerplate-docs.factor b/basis/furnace/boilerplate/boilerplate-docs.factor
index 5594928082..f8054c8d16 100644
--- a/basis/furnace/boilerplate/boilerplate-docs.factor
+++ b/basis/furnace/boilerplate/boilerplate-docs.factor
@@ -1,27 +1,37 @@
! Copyright (C) 2008 Your name.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax io.streams.string ;
+USING: help.markup help.syntax io.streams.string
+http.server.dispatchers ;
IN: furnace.boilerplate
HELP: <boilerplate>
{ $values
- { "responder" null }
- { "boilerplate" null }
+ { "responder" "a responder" }
+ { "boilerplate" "a new boilerplate responder" }
}
-{ $description "" } ;
+{ $description "Wraps a responder in a boilerplate responder. The boilerplate responder needs to be configured before use; see " { $link "furnace.boilerplate.config" } "." } ;
HELP: boilerplate
-{ $description "" } ;
+{ $class-description "The class of boilerplate responders. Slots are documented in " { $link "furnace.boilerplate.config" } "." } ;
-HELP: wrap-boilerplate?
-{ $values
- { "response" null }
- { "?" "a boolean" }
-}
-{ $description "" } ;
+ARTICLE: "furnace.boilerplate.config" "Boilerplate configuration"
+"The " { $link boilerplate } " tuple has two slots which can be set:"
+{ $table
+ { { $slot "template" } { "A pair with shape " { $snippet "{ responder name }" } ", where " { $snippet "responder" } " is a responder class, usually a subclass of " { $link dispatcher } ", and " { $snippet "name" } " is the name of a template file, without the " { $snippet ".xml" } " extension, relative to the directory containing the responder's vocabulary source file." } }
+ { { $slot "init" } { "A quotation run before the boilerplate template is rendered. This quotation can set values which the template can then display." } }
+} ;
+
+ARTICLE: "furnace.boilerplate.example" "Boilerplate example"
+"The " { $vocab-link "webapps.wiki" } " vocabulary uses boilerplate to add a footer and sidebar to every page. Since the footer and sidebar are themselves dynamic content, it sets the " { $slot "init" } " quotation as well as the " { $slot "template" } " slot:"
+{ $code "<boilerplate>"
+" [ init-sidebars init-relative-link-prefix ] >>init"
+" { wiki \"wiki-common\" } >>template" } ;
ARTICLE: "furnace.boilerplate" "Furnace boilerplate support"
-{ $vocab-link "furnace.boilerplate" }
-;
+"The " { $vocab-link "furnace.boilerplate" } " vocabulary implements a facility for sharing a common header and footer between different pages on a web site. It builds on top of " { $link "html.templates.boilerplate" } "."
+{ $subsection <boilerplate> }
+{ $subsection "furnace.boilerplate.config" }
+{ $subsection "furnace.boilerplate.example" }
+{ $see-also "html.templates.chloe.tags.boilerplate" } ;
ABOUT: "furnace.boilerplate"
From e6da3dc638551d3aac55c6476e82b5e19e1cd3e6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 14 Nov 2008 21:59:15 -0600
Subject: [PATCH 092/157] Document furnace.conversations
---
basis/furnace/asides/asides-docs.factor | 4 +-
.../boilerplate/boilerplate-docs.factor | 2 -
.../conversations/conversations-docs.factor | 53 ++++++++-
basis/furnace/furnace-docs.factor | 6 +-
basis/furnace/sessions/sessions-docs.factor | 110 +-----------------
.../syndication/syndication-docs.factor | 2 -
6 files changed, 58 insertions(+), 119 deletions(-)
diff --git a/basis/furnace/asides/asides-docs.factor b/basis/furnace/asides/asides-docs.factor
index b977474b5f..c5b7bdd537 100644
--- a/basis/furnace/asides/asides-docs.factor
+++ b/basis/furnace/asides/asides-docs.factor
@@ -5,7 +5,7 @@ IN: furnace.asides
HELP: <asides>
{ $values
{ "responder" "a responder" }
- { "responder'" asides }
+ { "responder'" "a new responder" }
}
{ $description "Creates a new " { $link asides } " responder wrapping an existing responder." } ;
@@ -22,7 +22,7 @@ ARTICLE: "furnace.asides" "Furnace asides"
$nl
"To use asides, wrap your responder in an aside responder:"
{ $subsection <asides> }
-"The aside responder must be wrapped inside a session responder (" { $link <sessions> } "), which in turn must be wrapped inside a database persistence responder (" { $link <db-persistence> } "). The " { $vocab-link "furnace.alloy" } " vocabulary combines all of these responders into one."
+"The asides responder must be wrapped inside a session responder (" { $link <sessions> } "), which in turn must be wrapped inside a database persistence responder (" { $link <db-persistence> } "). The " { $vocab-link "furnace.alloy" } " vocabulary combines all of these responders into one."
$nl
"Saving the current page in an aside which propagates through " { $link <redirect> } " responses:"
{ $subsection begin-aside }
diff --git a/basis/furnace/boilerplate/boilerplate-docs.factor b/basis/furnace/boilerplate/boilerplate-docs.factor
index f8054c8d16..ad983c8dc1 100644
--- a/basis/furnace/boilerplate/boilerplate-docs.factor
+++ b/basis/furnace/boilerplate/boilerplate-docs.factor
@@ -1,5 +1,3 @@
-! Copyright (C) 2008 Your name.
-! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax io.streams.string
http.server.dispatchers ;
IN: furnace.boilerplate
diff --git a/basis/furnace/conversations/conversations-docs.factor b/basis/furnace/conversations/conversations-docs.factor
index 5e161f2457..60844fadae 100644
--- a/basis/furnace/conversations/conversations-docs.factor
+++ b/basis/furnace/conversations/conversations-docs.factor
@@ -1,6 +1,53 @@
-USING: help.markup help.syntax ;
+USING: help.markup help.syntax urls http words kernel
+furnace.sessions furnace.db ;
IN: furnace.conversations
-ARTICLE: "furnace.conversations" "Furnace conversation scope"
+HELP: <conversations>
+{ $values
+ { "responder" "a responder" }
+ { "responder'" "a new responder" }
+}
+{ $description "Creates a new " { $link conversations } " responder wrapping an existing responder." } ;
-;
+HELP: begin-conversation
+{ $description "Starts a new conversation scope. Values can be stored in the conversation scope with " { $link cset } ", and the conversation can be continued with " { $link <continue-conversation> } "." } ;
+
+HELP: end-conversation
+{ $description "Ends the current conversation scope." } ;
+
+HELP: <continue-conversation>
+{ $values { "url" url } { "response" response } }
+{ $description "Creates an HTTP response which redirects the client to the specified URL while continuing the conversation. Any values set in the current conversation scope will be visible to the resonder handling the URL." } ;
+
+HELP: cget
+{ $values { "key" symbol } { "value" object } }
+{ $description "Outputs the value of a conversation variable." } ;
+
+HELP: cset
+{ $values { "value" object } { "key" symbol } }
+{ $description "Sets the value of a conversation variable." } ;
+
+HELP: cchange
+{ $values { "key" symbol } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } }
+{ $description "Applies the quotation to the old value of the conversation variable, and assigns the resulting value back to the variable." } ;
+
+ARTICLE: "furnace.conversations" "Furnace conversation scope"
+"The " { $vocab-link "furnace.conversations" } " vocabulary implements conversation scope, which allows data to be passed between requests on a finer level of granularity than session scope."
+$nl
+"Conversation scope is used by form validation to pass validation errors between requests."
+$nl
+"To use conversation scope, wrap your responder in an conversation responder:"
+{ $subsection <conversations> }
+"The conversations responder must be wrapped inside a session responder (" { $link <sessions> } "), which in turn must be wrapped inside a database persistence responder (" { $link <db-persistence> } "). The " { $vocab-link "furnace.alloy" } " vocabulary combines all of these responders into one."
+$nl
+"Managing conversation scopes:"
+{ $subsection begin-conversation }
+{ $subsection end-conversation }
+{ $subsection <continue-conversation> }
+"Reading and writing conversation variables:"
+{ $subsection cget }
+{ $subsection cset }
+{ $subsection cchange }
+"Note that conversation scope is serialized as part of the session, which means that only serializable objects can be stored there. See " { $link "furnace.sessions.serialize" } " for details." ;
+
+ABOUT: "furnace.conversations"
diff --git a/basis/furnace/furnace-docs.factor b/basis/furnace/furnace-docs.factor
index 0e2e6c1f40..c49940cc74 100644
--- a/basis/furnace/furnace-docs.factor
+++ b/basis/furnace/furnace-docs.factor
@@ -166,10 +166,8 @@ ARTICLE: "furnace" "Furnace web framework"
}
"Major functionality:"
{ $subsection "furnace.actions" }
-{ $subsection "furnace.syndication" }
-{ $subsection "furnace.boilerplate" }
-{ $subsection "furnace.db" }
"Server-side state:"
+{ $subsection "furnace.db" }
{ $subsection "furnace.sessions" }
{ $subsection "furnace.conversations" }
{ $subsection "furnace.asides" }
@@ -180,8 +178,10 @@ ARTICLE: "furnace" "Furnace web framework"
{ $subsection "html.templates" }
{ $subsection "html.templates.chloe" }
{ $subsection "html.templates.fhtml" }
+{ $subsection "furnace.boilerplate" }
"Utilities:"
{ $subsection "furnace.alloy" }
+{ $subsection "furnace.syndication" }
{ $subsection "furnace.json" }
{ $subsection "furnace.redirection" }
{ $subsection "furnace.referrer" } ;
diff --git a/basis/furnace/sessions/sessions-docs.factor b/basis/furnace/sessions/sessions-docs.factor
index 6ec77e00f5..f7aac7e2e9 100644
--- a/basis/furnace/sessions/sessions-docs.factor
+++ b/basis/furnace/sessions/sessions-docs.factor
@@ -1,22 +1,6 @@
-! Copyright (C) 2008 Your name.
-! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax io.streams.string quotations strings ;
IN: furnace.sessions
-HELP: <session-cookie>
-{ $values
-
- { "cookie" null }
-}
-{ $description "" } ;
-
-HELP: <session>
-{ $values
- { "id" null }
- { "session" null }
-}
-{ $description "" } ;
-
HELP: <sessions>
{ $values
{ "responder" null }
@@ -24,98 +8,18 @@ HELP: <sessions>
}
{ $description "" } ;
-HELP: begin-session
-{ $values
-
- { "session" null }
-}
-{ $description "" } ;
-
-HELP: check-session
-{ $values
- { "state/f" null }
- { "state/f" null }
-}
-{ $description "" } ;
-
-HELP: empty-session
-{ $values
-
- { "session" null }
-}
-{ $description "" } ;
-
-HELP: existing-session
-{ $values
- { "path" "a pathname string" } { "session" null }
- { "response" null }
-}
-{ $description "" } ;
-
-HELP: get-session
-{ $values
- { "id" null }
- { "session" null }
-}
-{ $description "" } ;
-
-HELP: init-session
-{ $values
- { "session" null }
-}
-{ $description "" } ;
-
HELP: init-session*
{ $values
{ "responder" null }
}
{ $description "" } ;
-HELP: put-session-cookie
-{ $values
- { "response" null }
- { "response'" null }
-}
-{ $description "" } ;
-
-HELP: remote-host
-{ $values
-
- { "string" string }
-}
-{ $description "" } ;
-
-HELP: request-session
-{ $values
-
- { "session/f" null }
-}
-{ $description "" } ;
-
-HELP: save-session-after
-{ $values
- { "session" null }
-}
-{ $description "" } ;
-
HELP: schange
{ $values
{ "key" null } { "quot" quotation }
}
{ $description "" } ;
-HELP: session
-{ $description "" } ;
-
-HELP: session-changed
-{ $description "" } ;
-
-HELP: session-id-key
-{ $description "" } ;
-
-HELP: sessions
-{ $description "" } ;
-
HELP: sget
{ $values
{ "key" null }
@@ -129,21 +33,13 @@ HELP: sset
}
{ $description "" } ;
-HELP: touch-session
-{ $values
- { "session" null }
-}
-{ $description "" } ;
+ARTICLE: "furnace.sessions.serialize" "Session state serialization"
-HELP: verify-session
-{ $values
- { "session" null }
- { "session" null }
-}
-{ $description "" } ;
+;
ARTICLE: "furnace.sessions" "Furnace sessions"
{ $vocab-link "furnace.sessions" }
+
;
ABOUT: "furnace.sessions"
diff --git a/basis/furnace/syndication/syndication-docs.factor b/basis/furnace/syndication/syndication-docs.factor
index 7a9ec57468..e68a5a2965 100644
--- a/basis/furnace/syndication/syndication-docs.factor
+++ b/basis/furnace/syndication/syndication-docs.factor
@@ -1,5 +1,3 @@
-! Copyright (C) 2008 Your name.
-! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax io.streams.string kernel sequences strings urls ;
IN: furnace.syndication
From 3d83ed07fdcd52d927caa07170b0b04c0d08d154 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 14 Nov 2008 22:49:17 -0600
Subject: [PATCH 093/157] Minor documentation updates: json, xml, serialize
---
basis/json/reader/reader-docs.factor | 10 +++++--
basis/json/writer/writer-docs.factor | 10 +++++--
basis/serialize/serialize-docs.factor | 38 ++++++++++++++++++---------
basis/serialize/serialize.factor | 4 +++
basis/xml/xml-docs.factor | 8 +++---
5 files changed, 48 insertions(+), 22 deletions(-)
diff --git a/basis/json/reader/reader-docs.factor b/basis/json/reader/reader-docs.factor
index ea4dcbf954..4700423db5 100644
--- a/basis/json/reader/reader-docs.factor
+++ b/basis/json/reader/reader-docs.factor
@@ -3,6 +3,12 @@
USING: help.markup help.syntax ;
IN: json.reader
-HELP: json> "( string -- object )"
-{ $values { "string" "a string in JSON format" } { "object" "yhe object deserialized from the JSON string" } }
+HELP: json> ( string -- object )
+{ $values { "string" "a string in JSON format" } { "object" "a deserialized object" } }
{ $description "Deserializes the JSON formatted string into a Factor object. JSON objects are converted to Factor hashtables. All other JSON objects convert to their obvious Factor equivalents." } ;
+
+ARTICLE: "json.reader" "JSON reader"
+"The " { $vocab-link "json.reader" } " vocabulary defines a word for parsing strings in JSON format."
+{ $subsection json> } ;
+
+ABOUT: "json.reader"
diff --git a/basis/json/writer/writer-docs.factor b/basis/json/writer/writer-docs.factor
index 21aa8b2cb5..8512d80384 100644
--- a/basis/json/writer/writer-docs.factor
+++ b/basis/json/writer/writer-docs.factor
@@ -3,13 +3,19 @@
USING: help.markup help.syntax ;
IN: json.writer
-HELP: >json "( obj -- string )"
+HELP: >json
{ $values { "obj" "an object" } { "string" "the object converted to JSON format" } }
{ $description "Serializes the object into a JSON formatted string." }
{ $see-also json-print } ;
-HELP: json-print "( obj -- )"
+HELP: json-print
{ $values { "obj" "an object" } }
{ $description "Serializes the object into a JSON formatted string and outputs it to the standard output stream." }
{ $see-also >json } ;
+ARTICLE: "json.writer" "JSON writer"
+"The " { $vocab-link "json.writer" } " vocabulary defines words for converting objects to JSON format."
+{ $subsection >json }
+{ $subsection json-print } ;
+
+ABOUT: "json.writer"
diff --git a/basis/serialize/serialize-docs.factor b/basis/serialize/serialize-docs.factor
index fc060d6b33..34922a5eae 100644
--- a/basis/serialize/serialize-docs.factor
+++ b/basis/serialize/serialize-docs.factor
@@ -1,22 +1,34 @@
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.syntax help.markup ;
+USING: help.syntax help.markup byte-arrays io ;
IN: serialize
HELP: serialize
-{ $values { "obj" "object to serialize" }
-}
-{ $description "Serializes the object to the current output stream. Object references within the structure being serialized are maintained." }
-{ $examples
- { $example "USING: serialize io.encodings.binary io.streams.byte-array prettyprint ;" "binary [ { 1 2 } serialize ] with-byte-writer\n\nbinary [ deserialize ] with-byte-reader ." "{ 1 2 }" }
-}
-{ $see-also deserialize } ;
+{ $values { "obj" "object to serialize" } }
+{ $description "Serializes the object to " { $link output-stream } "." } ;
HELP: deserialize
-{ $values { "obj" "deserialized object" }
+{ $values { "obj" "deserialized object" } }
+{ $description "Deserializes an object by reading from " { $link input-stream } "." } ;
+
+HELP: object>bytes
+{ $values { "obj" "object to serialize" } { "bytes" byte-array }
}
-{ $description "Deserializes an object by reading from the current input stream. Object references within the structure that was originally serialized are maintained." }
-{ $examples
- { $example "USING: serialize io.encodings.binary io.streams.byte-array prettyprint ;" "binary [ { 1 2 } serialize ] with-byte-writer\n\nbinary [ deserialize ] with-byte-reader ." "{ 1 2 }" }
+{ $description "Serializes the object to a byte array." } ;
+
+HELP: bytes>object
+{ $values { "bytes" byte-array } { "obj" "deserialized object" }
}
-{ $see-also serialize } ;
+{ $description "Deserializes an object from a byte array." } ;
+
+ARTICLE: "serialize" "Binary object serialization"
+"The " { $vocab-link "serialize" } " vocabulary implements binary serialization for all Factor data types except for continuations. Unlike the prettyprinter, shared structure and circularity is preserved."
+$nl
+"Storing objects on streams:"
+{ $subsection serialize }
+{ $subsection deserialize }
+"Storing objects as byte arrays:"
+{ $subsection object>bytes }
+{ $subsection bytes>object } ;
+
+ABOUT: "serialize"
diff --git a/basis/serialize/serialize.factor b/basis/serialize/serialize.factor
index 52c1535886..2e72fa12cf 100644
--- a/basis/serialize/serialize.factor
+++ b/basis/serialize/serialize.factor
@@ -15,6 +15,8 @@ locals prettyprint compiler.units sequences.private
classes.tuple.private ;
IN: serialize
+<PRIVATE
+
! Variable holding a assoc of objects already serialized
SYMBOL: serialized
@@ -299,6 +301,8 @@ SYMBOL: deserialized
: (deserialize) ( -- obj )
deserialize* [ "End of stream" throw ] unless ;
+PRIVATE>
+
: deserialize ( -- obj )
! [
V{ } clone deserialized
diff --git a/basis/xml/xml-docs.factor b/basis/xml/xml-docs.factor
index 6a2ff1109e..248a43ed63 100644
--- a/basis/xml/xml-docs.factor
+++ b/basis/xml/xml-docs.factor
@@ -460,10 +460,8 @@ ARTICLE: { "xml" "entities" } "XML entities"
{ $subsection with-entities }
{ $subsection with-html-entities } ;
-ARTICLE: { "xml" "intro" } "XML"
- "The XML module attempts to implement the XML 1.1 standard, converting strings of text into XML and vice versa. It currently is a work in progress."
- $nl
- "The XML module was implemented by Daniel Ehrenberg, with contributions from the Factor community"
+ARTICLE: "xml" "XML parser"
+"The " { $vocab-link "xml" } " vocabulary implements the XML 1.1 standard, converting strings of text into XML and vice versa."
{ $subsection { "xml" "reading" } }
{ $subsection { "xml" "writing" } }
{ $subsection { "xml" "classes" } }
@@ -476,4 +474,4 @@ ARTICLE: { "xml" "intro" } "XML"
IN: xml
-ABOUT: { "xml" "intro" }
+ABOUT: "xml"
From 5c914ff054e044024fdcb6fe843d84766dedb2c4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 14 Nov 2008 22:51:14 -0600
Subject: [PATCH 094/157] Remove bogus dependency
---
basis/validators/validators-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/validators/validators-docs.factor b/basis/validators/validators-docs.factor
index fc16c48ca0..8c78d6a0db 100644
--- a/basis/validators/validators-docs.factor
+++ b/basis/validators/validators-docs.factor
@@ -1,5 +1,5 @@
USING: help.markup help.syntax io.streams.string quotations
-strings math parser-combinators.regexp ;
+strings math regexp ;
IN: validators
HELP: v-captcha
From b9afd25245f87ead6d9ed4d0734d62d2873f1c43 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 14 Nov 2008 22:51:53 -0600
Subject: [PATCH 095/157] Document furnace.sessions
---
basis/furnace/furnace-docs.factor | 54 ++++++++++-----
basis/furnace/sessions/sessions-docs.factor | 66 +++++++++++--------
.../syndication/syndication-docs.factor | 50 +++++++-------
3 files changed, 100 insertions(+), 70 deletions(-)
diff --git a/basis/furnace/furnace-docs.factor b/basis/furnace/furnace-docs.factor
index c49940cc74..57181ff0e9 100644
--- a/basis/furnace/furnace-docs.factor
+++ b/basis/furnace/furnace-docs.factor
@@ -155,7 +155,31 @@ HELP: with-exit-continuation
}
{ $description "" } ;
-ARTICLE: "furnace" "Furnace web framework"
+ARTICLE: "furnace.persistence" "Furnace persistence layer"
+{ $subsection "furnace.db" }
+"Server-side state:"
+{ $subsection "furnace.sessions" }
+{ $subsection "furnace.conversations" }
+{ $subsection "furnace.asides" }
+{ $subsection "furnace.presentation" } ;
+
+ARTICLE: "furnace.presentation" "Furnace presentation layer"
+"HTML components:"
+{ $subsection "html.components" }
+{ $subsection "html.forms" }
+"Content templates:"
+{ $subsection "html.templates" }
+{ $subsection "html.templates.chloe" }
+{ $subsection "html.templates.fhtml" }
+{ $subsection "furnace.boilerplate" }
+"Other types of content:"
+{ $subsection "furnace.syndication" }
+{ $subsection "furnace.json" } ;
+
+ARTICLE: "furnace.load-balancing" "Load balancing and fail-over with Furnace"
+"The Furnace session manager persists sessions to a database. This means that HTTP requests can be transparently distributed between multiple Factor HTTP server instances, running the same web app on top of the same database, as long as the web applications do not use mutable global state, such as global variables. The Furnace framework itself does not use any mutable global state." ;
+
+ARTICLE: "furnace" "Furnace framework"
"The " { $vocab-link "furnace" } " vocabulary implements a full-featured web framework on top of the " { $link "http.server" } ". Some of its features include:"
{ $list
"Session management capable of load-balancing and fail-over"
@@ -166,24 +190,18 @@ ARTICLE: "furnace" "Furnace web framework"
}
"Major functionality:"
{ $subsection "furnace.actions" }
-"Server-side state:"
-{ $subsection "furnace.db" }
-{ $subsection "furnace.sessions" }
-{ $subsection "furnace.conversations" }
-{ $subsection "furnace.asides" }
-"HTML components:"
-{ $subsection "html.components" }
-{ $subsection "html.forms" }
-"Content templates:"
-{ $subsection "html.templates" }
-{ $subsection "html.templates.chloe" }
-{ $subsection "html.templates.fhtml" }
-{ $subsection "furnace.boilerplate" }
-"Utilities:"
{ $subsection "furnace.alloy" }
-{ $subsection "furnace.syndication" }
-{ $subsection "furnace.json" }
+{ $subsection "furnace.persistence" }
+{ $subsection "furnace.presentation" }
+{ $subsection "furnace.load-balancing" }
+"Utilities:"
+{ $subsection "furnace.referrer" }
{ $subsection "furnace.redirection" }
-{ $subsection "furnace.referrer" } ;
+"Related frameworks:"
+{ $subsection "db" }
+{ $subsection "xml" }
+{ $subsection "http.server" }
+{ $subsection "logging" }
+{ $subsection "urls" } ;
ABOUT: "furnace"
diff --git a/basis/furnace/sessions/sessions-docs.factor b/basis/furnace/sessions/sessions-docs.factor
index f7aac7e2e9..778452edc2 100644
--- a/basis/furnace/sessions/sessions-docs.factor
+++ b/basis/furnace/sessions/sessions-docs.factor
@@ -1,45 +1,55 @@
-USING: help.markup help.syntax io.streams.string quotations strings ;
+USING: help.markup help.syntax io.streams.string quotations strings calendar serialize kernel furnace.db words kernel ;
IN: furnace.sessions
HELP: <sessions>
{ $values
- { "responder" null }
- { "responder'" null }
+ { "responder" "a responder" }
+ { "responder'" "a new responder" }
}
-{ $description "" } ;
-
-HELP: init-session*
-{ $values
- { "responder" null }
-}
-{ $description "" } ;
+{ $description "Wraps a responder in a session manager responder." } ;
HELP: schange
-{ $values
- { "key" null } { "quot" quotation }
-}
-{ $description "" } ;
+{ $values { "key" symbol } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } }
+{ $description "Applies the quotation to the old value of the session variable, and assigns the resulting value back to the variable." } ;
HELP: sget
-{ $values
- { "key" null }
- { "value" null }
-}
-{ $description "" } ;
+{ $values { "key" symbol } { "value" object } }
+{ $description "Outputs the value of a session variable." } ;
HELP: sset
-{ $values
- { "value" null } { "key" null }
-}
-{ $description "" } ;
+{ $values { "value" object } { "key" symbol } }
+{ $description "Sets the value of a session variable." } ;
+
+ARTICLE: "furnace.sessions.config" "Session manager configuration"
+"The " { $link sessions } " tuple has two slots which contain configuration parameters:"
+{ $table
+ { { $slot "verify?" } { "If set to a true value, the client IP address and user agent of each session is tracked, and checked every time a client attempts to re-establish a session. While this does not offer any real security, it can thwart unskilled packet-sniffing attacks. On by default." } }
+ { { $slot "timeout" } { "A " { $link duration } " storing the maximum time that inactive sessions will be stored on the server. The default timeout is 20 minutes. Note that for sessions to actually expire, you must start a thread to do so; see the " { $vocab-link "furnace.alloy" } " vocabulary for an easy way of doing this." } }
+} ;
ARTICLE: "furnace.sessions.serialize" "Session state serialization"
-
-;
+"Session variable values are serialized to the database using the " { $link "serialize" } " library."
+$nl
+"This means that there are three restrictions on the values stored in the session:"
+{ $list
+ "Continuations cannot be stored at all."
+ { "Object identity is not preserved between serialization and deserialization. That is, if an object is stored with " { $link sset } " and later retrieved with " { $link sget } ", the retrieved value will be " { $link = } " to the original, but not necessarily " { $link eq? } "." }
+ { "All objects reachable from the value passed to " { $link sset } " are serialized, so large structures should not be stored in the session state, and neither should anything that can reference the global namespace. Large structures should be persisted in the database directly instead, using " { $vocab-link "db.tuples" } "." }
+} ;
ARTICLE: "furnace.sessions" "Furnace sessions"
-{ $vocab-link "furnace.sessions" }
-
-;
+"The " { $vocab-link "furnace.sessions" } " vocabulary implements session management, which allows state to be maintained between HTTP requests. The session state is stored on the server; the client receives an opaque ID which is saved in a cookie (for GET requests) or a hidden form field (for POST requests)."
+$nl
+"To use session management, wrap your responder in an session manager:"
+{ $subsection <sessions> }
+"The sessions responder must be wrapped inside a database persistence responder (" { $link <db-persistence> } "). The " { $vocab-link "furnace.alloy" } " vocabulary combines all of these responders into one."
+$nl
+"Reading and writing session variables from a request:"
+{ $subsection sget }
+{ $subsection sset }
+{ $subsection schange }
+"Additional topics:"
+{ $subsection "furnace.sessions.config" }
+{ $subsection "furnace.sessions.serialize" } ;
ABOUT: "furnace.sessions"
diff --git a/basis/furnace/syndication/syndication-docs.factor b/basis/furnace/syndication/syndication-docs.factor
index e68a5a2965..a1fb84f0e5 100644
--- a/basis/furnace/syndication/syndication-docs.factor
+++ b/basis/furnace/syndication/syndication-docs.factor
@@ -1,29 +1,23 @@
-USING: help.markup help.syntax io.streams.string kernel sequences strings urls ;
+USING: help.markup help.syntax io.streams.string kernel sequences strings urls syndication ;
IN: furnace.syndication
HELP: <feed-action>
-{ $values
-
- { "action" null }
-}
-{ $description "" } ;
-
-HELP: <feed-content>
-{ $values
- { "body" null }
- { "response" null }
-}
-{ $description "" } ;
+{ $values { "action" feed-action } }
+{ $description "Creates a new Atom feed action." } ;
HELP: >entry
{ $values
{ "object" object }
- { "entry" null }
+ { "entry" entry }
}
-{ $description "" } ;
+{ $contract "Converts an object into an Atom feed entry. The default implementation constructs an entry by calling "
+{ $link feed-entry-title } ", "
+{ $link feed-entry-description } ", "
+{ $link feed-entry-date } ", and "
+{ $link feed-entry-url } "." } ;
HELP: feed-action
-{ $description "" } ;
+{ $class-description "The class of feed actions. Contains several slots, documented in " { $link "furnace.syndication.config" } "." } ;
HELP: feed-entry-date
{ $values
@@ -53,15 +47,23 @@ HELP: feed-entry-url
}
{ $description "" } ;
-HELP: process-entries
-{ $values
- { "seq" sequence }
- { "seq'" sequence }
-}
-{ $description "" } ;
+ARTICLE: "furnace.syndication.config" "Configuring Atom feed actions"
-ARTICLE: "furnace.syndication" "Furnace Atom syndication support"
-{ $vocab-link "furnace.syndication" }
;
+ARTICLE: "furnace.syndication.protocol" "Atom feed entry protocol"
+"An Atom feed action takes a sequence of objects and converts them into Atom feed entries. The objects must implement a protocol consisting of either a single generic word:"
+{ $subsection >entry }
+"Or a series of generic words, called by the default implementation of " { $link >entry } ":"
+{ $subsection feed-entry-title }
+{ $subsection feed-entry-description }
+{ $subsection feed-entry-date }
+{ $subsection feed-entry-url } ;
+
+ARTICLE: "furnace.syndication" "Furnace Atom syndication support"
+"The " { $vocab-link "furnace.syndication" } " vocabulary builds on the " { $link "syndication" } " library by providing easy support for generating Atom feeds from " { $link "furnace.actions" } "."
+{ $subsection <feed-action> }
+{ $subsection "furnace.syndication.config" }
+{ $subsection "furnace.syndication.protocol" } ;
+
ABOUT: "furnace.syndication"
From c3c5b4f9449ba61514d149e4307fc8c85fae4183 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 14 Nov 2008 23:01:04 -0600
Subject: [PATCH 096/157] Document furnace.syndication
---
.../syndication/syndication-docs.factor | 20 +++++++++++--------
1 file changed, 12 insertions(+), 8 deletions(-)
diff --git a/basis/furnace/syndication/syndication-docs.factor b/basis/furnace/syndication/syndication-docs.factor
index a1fb84f0e5..94a69ccd0e 100644
--- a/basis/furnace/syndication/syndication-docs.factor
+++ b/basis/furnace/syndication/syndication-docs.factor
@@ -1,4 +1,4 @@
-USING: help.markup help.syntax io.streams.string kernel sequences strings urls syndication ;
+USING: help.markup help.syntax io.streams.string kernel sequences strings urls syndication calendar ;
IN: furnace.syndication
HELP: <feed-action>
@@ -22,34 +22,38 @@ HELP: feed-action
HELP: feed-entry-date
{ $values
{ "object" object }
- { "timestamp" null }
+ { "timestamp" timestamp }
}
-{ $description "" } ;
+{ $contract "Outputs a feed entry timestmap." } ;
HELP: feed-entry-description
{ $values
{ "object" object }
{ "description" null }
}
-{ $description "" } ;
+{ $contract "Outputs a feed entry description." } ;
HELP: feed-entry-title
{ $values
{ "object" object }
{ "string" string }
}
-{ $description "" } ;
+{ $contract "Outputs a feed entry title." } ;
HELP: feed-entry-url
{ $values
{ "object" object }
{ "url" url }
}
-{ $description "" } ;
+{ $contract "Outputs a feed entry URL." } ;
ARTICLE: "furnace.syndication.config" "Configuring Atom feed actions"
-
-;
+"Instances of " { $link feed-action } " have three slots which need to be set:"
+{ $table
+ { { $slot "title" } "The title of the feed as a string" }
+ { { $slot "url" } { "The feed " { $link url } } }
+ { { $slot "entries" } { "A quotation with stack effect " { $snippet "( -- seq )" } ", which produces a sequence of objects responding to the " { $link "furnace.syndication.protocol" } " protocol" } }
+} ;
ARTICLE: "furnace.syndication.protocol" "Atom feed entry protocol"
"An Atom feed action takes a sequence of objects and converts them into Atom feed entries. The objects must implement a protocol consisting of either a single generic word:"
From 821fb8969c576c64517ab35c184987cd195ad276 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 14 Nov 2008 23:01:12 -0600
Subject: [PATCH 097/157] Fix validators docs
---
basis/validators/validators-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/validators/validators-docs.factor b/basis/validators/validators-docs.factor
index 8c78d6a0db..4f03fa915b 100644
--- a/basis/validators/validators-docs.factor
+++ b/basis/validators/validators-docs.factor
@@ -1,5 +1,5 @@
USING: help.markup help.syntax io.streams.string quotations
-strings math regexp ;
+strings math regexp regexp.backend ;
IN: validators
HELP: v-captcha
From ca1f3b5af0c42c943f2111957280f8658f6276c4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 15 Nov 2008 02:35:53 -0600
Subject: [PATCH 098/157] (serialize) should not be private since
concurrency.distributed defines a method
---
basis/serialize/serialize.factor | 7 ++-----
1 file changed, 2 insertions(+), 5 deletions(-)
diff --git a/basis/serialize/serialize.factor b/basis/serialize/serialize.factor
index 2e72fa12cf..f062548482 100644
--- a/basis/serialize/serialize.factor
+++ b/basis/serialize/serialize.factor
@@ -15,6 +15,8 @@ locals prettyprint compiler.units sequences.private
classes.tuple.private ;
IN: serialize
+GENERIC: (serialize) ( obj -- )
+
<PRIVATE
! Variable holding a assoc of objects already serialized
@@ -37,9 +39,6 @@ M: id equal? over id? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
#! Return the id of an already serialized object
<id> serialized get at ;
-! Serialize object
-GENERIC: (serialize) ( obj -- )
-
! Numbers are serialized as follows:
! 0 => B{ 0 }
! 1<=x<=126 => B{ x | 0x80 }
@@ -304,10 +303,8 @@ SYMBOL: deserialized
PRIVATE>
: deserialize ( -- obj )
- ! [
V{ } clone deserialized
[ (deserialize) ] with-variable ;
- ! ] with-compilation-unit ;
: serialize ( obj -- )
H{ } clone serialized [ (serialize) ] with-variable ;
From e313988bf0183489122a31b436ce86fa52b068c1 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 15 Nov 2008 03:07:55 -0600
Subject: [PATCH 099/157] json.writer now converts ratios to floats
---
basis/json/json.factor | 3 +++
basis/json/reader/reader-tests.factor | 3 ++-
basis/json/reader/reader.factor | 10 ++++++----
basis/json/writer/writer-tests.factor | 6 ++++--
basis/json/writer/writer.factor | 14 ++++++++------
5 files changed, 23 insertions(+), 13 deletions(-)
create mode 100644 basis/json/json.factor
diff --git a/basis/json/json.factor b/basis/json/json.factor
new file mode 100644
index 0000000000..08d2590ee7
--- /dev/null
+++ b/basis/json/json.factor
@@ -0,0 +1,3 @@
+IN: json
+
+SINGLETON: json-null
diff --git a/basis/json/reader/reader-tests.factor b/basis/json/reader/reader-tests.factor
index fbd91601bf..e97d45babe 100644
--- a/basis/json/reader/reader-tests.factor
+++ b/basis/json/reader/reader-tests.factor
@@ -1,4 +1,5 @@
-USING: arrays json.reader kernel multiline strings tools.test hashtables ;
+USING: arrays json.reader kernel multiline strings tools.test
+hashtables json ;
IN: json.reader.tests
{ f } [ "false" json> ] unit-test
diff --git a/basis/json/reader/reader.factor b/basis/json/reader/reader.factor
index 858c9ed4de..f1520a9272 100644
--- a/basis/json/reader/reader.factor
+++ b/basis/json/reader/reader.factor
@@ -1,14 +1,16 @@
! Copyright (C) 2008 Peter Burns.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel peg peg.ebnf math.parser math.private strings math math.functions sequences
- arrays vectors hashtables assocs prettyprint ;
+USING: kernel peg peg.ebnf math.parser math.private strings math
+math.functions sequences arrays vectors hashtables assocs
+prettyprint json ;
IN: json.reader
-SINGLETON: json-null
-
+<PRIVATE
: grammar-list>vector ( seq -- vec ) first2 values swap prefix ;
+PRIVATE>
+
! Grammar for JSON from RFC 4627
EBNF: json>
diff --git a/basis/json/writer/writer-tests.factor b/basis/json/writer/writer-tests.factor
index 1b29bac824..6b6118c443 100644
--- a/basis/json/writer/writer-tests.factor
+++ b/basis/json/writer/writer-tests.factor
@@ -1,4 +1,4 @@
-USING: json.writer tools.test multiline json.reader ;
+USING: json.writer tools.test multiline json.reader json ;
IN: json.writer.tests
{ "false" } [ f >json ] unit-test
@@ -15,4 +15,6 @@ IN: json.writer.tests
! Random symbols are written simply as strings
SYMBOL: testSymbol
-{ <" "testSymbol""> } [ testSymbol >json ] unit-test
\ No newline at end of file
+{ <" "testSymbol""> } [ testSymbol >json ] unit-test
+
+[ { 0.5 } ] [ { 1/2 } >json json> ] unit-test
\ No newline at end of file
diff --git a/basis/json/writer/writer.factor b/basis/json/writer/writer.factor
index d50a4de8f5..e374919039 100644
--- a/basis/json/writer/writer.factor
+++ b/basis/json/writer/writer.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel io.streams.string io strings splitting sequences
-math math.parser assocs classes words namespaces make
-prettyprint hashtables mirrors tr json.reader ;
+USING: accessors kernel io.streams.string io strings splitting
+sequences math math.parser assocs classes words namespaces make
+prettyprint hashtables mirrors tr json ;
IN: json.writer
#! Writes the object out to a stream in JSON format
@@ -24,9 +24,12 @@ M: json-null json-print ( null -- )
M: string json-print ( obj -- )
CHAR: " write1 "\"" split "\\\"" join CHAR: \r swap remove "\n" split "\\r\\n" join write CHAR: " write1 ;
-M: number json-print ( num -- )
+M: integer json-print ( num -- )
number>string write ;
+M: real json-print ( num -- )
+ >float number>string write ;
+
M: sequence json-print ( array -- )
CHAR: [ write1 [ >json ] map "," join write CHAR: ] write1 ;
@@ -46,5 +49,4 @@ M: hashtable json-print ( hashtable -- )
{ } assoc>map "," join write
CHAR: } write1 ;
-M: object json-print ( object -- )
- unparse json-print ;
+M: word json-print name>> json-print ;
From dced1da5b58ef499b4048be212677f70eef01adb Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 15 Nov 2008 03:09:57 -0600
Subject: [PATCH 100/157] More JSON tweaks
---
basis/json/json-docs.factor | 8 ++++++++
basis/json/json.factor | 4 ++++
basis/json/reader/reader-docs.factor | 2 +-
basis/json/reader/reader.factor | 10 ++++++----
4 files changed, 19 insertions(+), 5 deletions(-)
create mode 100644 basis/json/json-docs.factor
diff --git a/basis/json/json-docs.factor b/basis/json/json-docs.factor
new file mode 100644
index 0000000000..816e7236ac
--- /dev/null
+++ b/basis/json/json-docs.factor
@@ -0,0 +1,8 @@
+IN: json
+USING: help.markup help.syntax ;
+
+ARTICLE: "json" "JSON serialization"
+{ $subsection "json.reader" }
+{ $subsection "json.writer" } ;
+
+ABOUT: "json"
diff --git a/basis/json/json.factor b/basis/json/json.factor
index 08d2590ee7..d7cfc0e5bc 100644
--- a/basis/json/json.factor
+++ b/basis/json/json.factor
@@ -1,3 +1,7 @@
IN: json
+USE: vocabs.loader
SINGLETON: json-null
+
+"json.reader" require
+"json.writer" require
diff --git a/basis/json/reader/reader-docs.factor b/basis/json/reader/reader-docs.factor
index 4700423db5..4446c385d3 100644
--- a/basis/json/reader/reader-docs.factor
+++ b/basis/json/reader/reader-docs.factor
@@ -3,7 +3,7 @@
USING: help.markup help.syntax ;
IN: json.reader
-HELP: json> ( string -- object )
+HELP: json>
{ $values { "string" "a string in JSON format" } { "object" "a deserialized object" } }
{ $description "Deserializes the JSON formatted string into a Factor object. JSON objects are converted to Factor hashtables. All other JSON objects convert to their obvious Factor equivalents." } ;
diff --git a/basis/json/reader/reader.factor b/basis/json/reader/reader.factor
index f1520a9272..0014ba1eb1 100644
--- a/basis/json/reader/reader.factor
+++ b/basis/json/reader/reader.factor
@@ -9,10 +9,8 @@ IN: json.reader
: grammar-list>vector ( seq -- vec ) first2 values swap prefix ;
-PRIVATE>
-
! Grammar for JSON from RFC 4627
-EBNF: json>
+EBNF: (json>)
ws = (" " | "\r" | "\t" | "\n")*
@@ -56,4 +54,8 @@ val = true
value = ws val:v ws => [[ v ]]
-;EBNF
\ No newline at end of file
+;EBNF
+
+PRIVATE>
+
+: json> ( string -- object ) (json>) ;
\ No newline at end of file
From b44bc33d1b3f0fa8039eb2ca3cb270d8cdd645e7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 15 Nov 2008 04:13:03 -0600
Subject: [PATCH 101/157] Fix serialize tsets
---
basis/serialize/serialize-tests.factor | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/basis/serialize/serialize-tests.factor b/basis/serialize/serialize-tests.factor
index 3a75ad65b6..4ed534151b 100644
--- a/basis/serialize/serialize-tests.factor
+++ b/basis/serialize/serialize-tests.factor
@@ -1,10 +1,10 @@
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
-USING: tools.test kernel serialize io io.streams.byte-array math
-alien arrays byte-arrays bit-arrays float-arrays sequences math
-prettyprint parser classes math.constants io.encodings.binary
-random assocs ;
+USING: tools.test kernel serialize serialize.private io
+io.streams.byte-array math alien arrays byte-arrays bit-arrays
+float-arrays sequences math prettyprint parser classes
+math.constants io.encodings.binary random assocs ;
IN: serialize.tests
: test-serialize-cell
From 74e5979ba85741aa3a56bdba015d1b6d214337cc Mon Sep 17 00:00:00 2001
From: "Jose A. Ortega Ruiz" <jao@gnu.org>
Date: Sun, 16 Nov 2008 00:16:13 +0100
Subject: [PATCH 102/157] Font lock improvements (highlight word, symbol and
tuple definitions).
---
misc/factor.el | 19 +++++++++++++++++--
1 file changed, 17 insertions(+), 2 deletions(-)
diff --git a/misc/factor.el b/misc/factor.el
index 2afb5a7b7f..553597a1c2 100644
--- a/misc/factor.el
+++ b/misc/factor.el
@@ -91,11 +91,23 @@
"TUPLE:" "T{" "t\\??" "TYPEDEF:"
"UNION:" "USE:" "USING:" "V{" "VAR:" "VARS:" "W{"))
-(defconst factor--regex--parsing-words-ext
+(defconst factor--regex-parsing-words-ext
(regexp-opt '("B" "call-next-method" "delimiter" "f" "flushable" "foldable"
"initial:" "inline" "parsing" "read-only" "recursive")
'words))
+(defun factor--regex-second-word (prefixes)
+ (format "^%s +\\([^ ]+\\)" (regexp-opt prefixes t)))
+
+(defconst factor--regex-word-definition
+ (factor--regex-second-word '(":" "::" "M:" "GENERIC:")))
+
+(defconst factor--regex-type-definition
+ (factor--regex-second-word '("TUPLE:")))
+
+(defconst factor--regex-const-definition
+ (factor--regex-second-word '("SYMBOL:")))
+
(defconst factor-font-lock-keywords
`(("#!.*$" . font-lock-comment-face)
("!( .* )" . font-lock-comment-face)
@@ -108,7 +120,10 @@
,@(mapcar #'(lambda (w) (cons (concat "\\(^\\| \\)\\(" w "\\)\\($\\| \\)")
'(2 font-lock-keyword-face)))
factor--parsing-words)
- (,factor--regex--parsing-words-ext . font-lock-keyword-face)))
+ (,factor--regex-parsing-words-ext . font-lock-keyword-face)
+ (,factor--regex-word-definition 2 font-lock-function-name-face)
+ (,factor--regex-type-definition 2 font-lock-type-face)
+ (,factor--regex-const-definition 2 font-lock-constant-face)))
(defun factor-indent-line ()
"Indent current line as Factor code"
From e7ccb46254f5d3553e4e9bd156681785aba6e2e4 Mon Sep 17 00:00:00 2001
From: "Jose A. Ortega Ruiz" <jao@gnu.org>
Date: Sun, 16 Nov 2008 00:19:05 +0100
Subject: [PATCH 103/157] Show keybindings for factor-mode in help buffer (C-h
m).
---
misc/factor.el | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/misc/factor.el b/misc/factor.el
index 553597a1c2..5d937c14ca 100644
--- a/misc/factor.el
+++ b/misc/factor.el
@@ -130,7 +130,8 @@
(indent-line-to (+ (current-indentation) 4)))
(defun factor-mode ()
- "A mode for editing programs written in the Factor programming language."
+ "A mode for editing programs written in the Factor programming language.
+\\{factor-mode-map}"
(interactive)
(kill-all-local-variables)
(use-local-map factor-mode-map)
From aa43297364ae68b6ffc1c17c88bea5884462df72 Mon Sep 17 00:00:00 2001
From: "Jose A. Ortega Ruiz" <jao@gnu.org>
Date: Sun, 16 Nov 2008 01:27:21 +0100
Subject: [PATCH 104/157] Better string font lock (catch scaped quotes).
---
misc/factor.el | 3 +--
1 file changed, 1 insertion(+), 2 deletions(-)
diff --git a/misc/factor.el b/misc/factor.el
index 5d937c14ca..fe050d18f2 100644
--- a/misc/factor.el
+++ b/misc/factor.el
@@ -114,8 +114,7 @@
("^!.*$" . font-lock-comment-face)
(" !.*$" . font-lock-comment-face)
("( .* )" . font-lock-comment-face)
- ("\"[^ ][^\"]*\"" . font-lock-string-face)
- ("\"\"" . font-lock-string-face)
+ ("\"\\(\\\\\"\\|[^\"]\\)*\"" . font-lock-string-face)
("\\(P\\|SBUF\\)\"" 1 font-lock-keyword-face)
,@(mapcar #'(lambda (w) (cons (concat "\\(^\\| \\)\\(" w "\\)\\($\\| \\)")
'(2 font-lock-keyword-face)))
From 16cc4093549502c4a1cb8862c72034770d2081a4 Mon Sep 17 00:00:00 2001
From: "Jose A. Ortega Ruiz" <jao@gnu.org>
Date: Sun, 16 Nov 2008 01:51:20 +0100
Subject: [PATCH 105/157] Font lock for USE: and USING: args.
---
misc/factor.el | 9 +++++++--
1 file changed, 7 insertions(+), 2 deletions(-)
diff --git a/misc/factor.el b/misc/factor.el
index fe050d18f2..0b12077977 100644
--- a/misc/factor.el
+++ b/misc/factor.el
@@ -82,7 +82,7 @@
(defconst factor--parsing-words
'("{" "}" "^:" "^::" ";" "<<" "<PRIVATE" ">>"
"BIN:" "BV{" "B{" "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CS{" "C{"
- "DEFER:" "ERROR:" "FORGET:"
+ "DEFER:" "ERROR:" "EXCLUDE:" "FORGET:"
"GENERIC#" "GENERIC:" "HEX:" "HOOK:" "H{"
"IN:" "INSTANCE:" "INTERSECTION:"
"M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "METHOD:" "MIXIN:"
@@ -108,6 +108,9 @@
(defconst factor--regex-const-definition
(factor--regex-second-word '("SYMBOL:")))
+(defconst factor--regex-using-line "^USING: +\\([^;]*\\);")
+(defconst factor--regex-use-line "^USE: +\\(.*\\)$")
+
(defconst factor-font-lock-keywords
`(("#!.*$" . font-lock-comment-face)
("!( .* )" . font-lock-comment-face)
@@ -122,7 +125,9 @@
(,factor--regex-parsing-words-ext . font-lock-keyword-face)
(,factor--regex-word-definition 2 font-lock-function-name-face)
(,factor--regex-type-definition 2 font-lock-type-face)
- (,factor--regex-const-definition 2 font-lock-constant-face)))
+ (,factor--regex-const-definition 2 font-lock-constant-face)
+ (,factor--regex-using-line 1 font-lock-constant-face)
+ (,factor--regex-use-line 1 font-lock-constant-face)))
(defun factor-indent-line ()
"Indent current line as Factor code"
From 74c59d1531417c30c84979ce805d2a7cb28b7ae4 Mon Sep 17 00:00:00 2001
From: "Jose A. Ortega Ruiz" <jao@gnu.org>
Date: Sun, 16 Nov 2008 03:16:57 +0100
Subject: [PATCH 106/157] Faces used in factor-mode are now customizable (plus
a bit of reordering in factor.el).
---
misc/factor.el | 146 ++++++++++++++++++++++++++++++++++---------------
1 file changed, 102 insertions(+), 44 deletions(-)
diff --git a/misc/factor.el b/misc/factor.el
index 0b12077977..b25493dd5e 100644
--- a/misc/factor.el
+++ b/misc/factor.el
@@ -31,6 +31,9 @@
:type '(choice (const :tag "Enable" t) (const :tag "Disable" nil))
:group 'factor)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; factor-mode syntax
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(if factor-mode-syntax-table
()
@@ -72,13 +75,60 @@
(modify-syntax-entry ?\) ")(" factor-mode-syntax-table)
(modify-syntax-entry ?\" "\" " factor-mode-syntax-table)))
-(defvar factor-mode-map (make-sparse-keymap))
-
(defcustom factor-mode-hook nil
"Hook run when entering Factor mode."
:type 'hook
:group 'factor)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; factor-mode font lock
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(require 'font-lock)
+
+(defgroup factor-faces nil
+ "Faces used in Factor mode"
+ :group 'factor
+ :group 'faces)
+
+(defsubst factor--face (face) `((t ,(face-attr-construct face))))
+
+(defface factor-font-lock-parsing-word (factor--face font-lock-keyword-face)
+ "Face for parsing words."
+ :group 'factor-faces)
+
+(defface factor-font-lock-comment (factor--face font-lock-comment-face)
+ "Face for comments."
+ :group 'factor-faces)
+
+(defface factor-font-lock-string (factor--face font-lock-string-face)
+ "Face for strings."
+ :group 'factor-faces)
+
+(defface factor-font-lock-stack-effect (factor--face font-lock-comment-face)
+ "Face for stack effect specifications."
+ :group 'factor-faces)
+
+(defface factor-font-lock-word-definition (factor--face font-lock-function-name-face)
+ "Face for word, generic or method being defined."
+ :group 'factor-faces)
+
+(defface factor-font-lock-symbol-definition (factor--face font-lock-variable-name-face)
+ "Face for name of symbol being defined."
+ :group 'factor-faces)
+
+(defface factor-font-lock-vocabulary-name (factor--face font-lock-constant-face)
+ "Face for names of vocabularies in USE or USING."
+ :group 'factor-faces)
+
+(defface factor-font-lock-type-definition (factor--face font-lock-type-face)
+ "Face for type (tuple) names."
+ :group 'factor-faces)
+
+(defface factor-font-lock-parsing-word (factor--face font-lock-keyword-face)
+ "Face for parsing words."
+ :group 'factor-faces)
+
(defconst factor--parsing-words
'("{" "}" "^:" "^::" ";" "<<" "<PRIVATE" ">>"
"BIN:" "BV{" "B{" "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CS{" "C{"
@@ -97,7 +147,7 @@
'words))
(defun factor--regex-second-word (prefixes)
- (format "^%s +\\([^ ]+\\)" (regexp-opt prefixes t)))
+ (format "^%s +\\([^ \r\n]+\\)" (regexp-opt prefixes t)))
(defconst factor--regex-word-definition
(factor--regex-second-word '(":" "::" "M:" "GENERIC:")))
@@ -105,56 +155,33 @@
(defconst factor--regex-type-definition
(factor--regex-second-word '("TUPLE:")))
-(defconst factor--regex-const-definition
+(defconst factor--regex-symbol-definition
(factor--regex-second-word '("SYMBOL:")))
(defconst factor--regex-using-line "^USING: +\\([^;]*\\);")
(defconst factor--regex-use-line "^USE: +\\(.*\\)$")
(defconst factor-font-lock-keywords
- `(("#!.*$" . font-lock-comment-face)
- ("!( .* )" . font-lock-comment-face)
- ("^!.*$" . font-lock-comment-face)
- (" !.*$" . font-lock-comment-face)
- ("( .* )" . font-lock-comment-face)
- ("\"\\(\\\\\"\\|[^\"]\\)*\"" . font-lock-string-face)
- ("\\(P\\|SBUF\\)\"" 1 font-lock-keyword-face)
+ `(("#!.*$" . 'factor-font-lock-comment)
+ ("!( .* )" . 'factor-font-lock-comment)
+ ("^!.*$" . 'factor-font-lock-comment)
+ (" !.*$" . 'factor-font-lock-comment)
+ ("( .* )" . 'factor-font-lock-stack-effect)
+ ("\"\\(\\\\\"\\|[^\"]\\)*\"" . 'factor-font-lock-string)
+ ("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word)
,@(mapcar #'(lambda (w) (cons (concat "\\(^\\| \\)\\(" w "\\)\\($\\| \\)")
- '(2 font-lock-keyword-face)))
+ '(2 'factor-font-lock-parsing-word)))
factor--parsing-words)
- (,factor--regex-parsing-words-ext . font-lock-keyword-face)
- (,factor--regex-word-definition 2 font-lock-function-name-face)
- (,factor--regex-type-definition 2 font-lock-type-face)
- (,factor--regex-const-definition 2 font-lock-constant-face)
- (,factor--regex-using-line 1 font-lock-constant-face)
- (,factor--regex-use-line 1 font-lock-constant-face)))
-
-(defun factor-indent-line ()
- "Indent current line as Factor code"
- (indent-line-to (+ (current-indentation) 4)))
-
-(defun factor-mode ()
- "A mode for editing programs written in the Factor programming language.
-\\{factor-mode-map}"
- (interactive)
- (kill-all-local-variables)
- (use-local-map factor-mode-map)
- (setq major-mode 'factor-mode)
- (setq mode-name "Factor")
- (set (make-local-variable 'indent-line-function) #'factor-indent-line)
- (make-local-variable 'comment-start)
- (setq comment-start "! ")
- (make-local-variable 'font-lock-defaults)
- (setq font-lock-defaults
- '(factor-font-lock-keywords t nil nil nil))
- (set-syntax-table factor-mode-syntax-table)
- (make-local-variable 'indent-line-function)
- (setq indent-line-function 'factor-indent-line)
- (run-hooks 'factor-mode-hook))
-
-(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))
+ (,factor--regex-parsing-words-ext . 'factor-font-lock-parsing-word)
+ (,factor--regex-word-definition 2 'factor-font-lock-word-definition)
+ (,factor--regex-type-definition 2 'factor-font-lock-type-definition)
+ (,factor--regex-symbol-definition 2 'factor-font-lock-symbol-definition)
+ (,factor--regex-using-line 1 'factor-font-lock-vocabulary-name)
+ (,factor--regex-use-line 1 'factor-font-lock-vocabulary-name)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; factor-mode commands
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(require 'comint)
@@ -247,6 +274,8 @@
(beginning-of-line)
(insert "! "))
+(defvar factor-mode-map (make-sparse-keymap))
+
(define-key factor-mode-map "\C-c\C-f" 'factor-run-file)
(define-key factor-mode-map "\C-c\C-r" 'factor-send-region)
(define-key factor-mode-map "\C-c\C-d" 'factor-send-definition)
@@ -258,9 +287,13 @@
(define-key factor-mode-map [tab] 'indent-for-tab-command)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; indentation
+;; factor-mode indentation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun factor-indent-line ()
+ "Indent current line as Factor code"
+ (indent-line-to (+ (current-indentation) 4)))
+
(defconst factor-word-starting-keywords
'("" ":" "TUPLE" "MACRO" "MACRO:" "M"))
@@ -323,6 +356,31 @@
(if (> (- (point-max) pos) (point))
(goto-char (- (point-max) pos))))))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; factor-mode
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun factor-mode ()
+ "A mode for editing programs written in the Factor programming language.
+\\{factor-mode-map}"
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map factor-mode-map)
+ (setq major-mode 'factor-mode)
+ (setq mode-name "Factor")
+ (set (make-local-variable 'indent-line-function) #'factor-indent-line)
+ (make-local-variable 'comment-start)
+ (setq comment-start "! ")
+ (make-local-variable 'font-lock-defaults)
+ (setq font-lock-defaults
+ '(factor-font-lock-keywords t nil nil nil))
+ (set-syntax-table factor-mode-syntax-table)
+ (make-local-variable 'indent-line-function)
+ (setq indent-line-function 'factor-indent-line)
+ (run-hooks 'factor-mode-hook))
+
+(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; factor-listener-mode
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
From 7fc13ef03c2c013efed1692f8c142465654834e6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 05:53:25 -0600
Subject: [PATCH 107/157] dlists no longer have a length slot; tweak dlist code
so that types infer better
---
basis/compiler/compiler.factor | 4 +-
.../tree/dead-code/liveness/liveness.factor | 5 +-
basis/compiler/tree/def-use/def-use.factor | 8 +-
.../compiler/tree/recursive/recursive.factor | 2 +-
basis/deques/deques-docs.factor | 25 +++----
basis/deques/deques.factor | 5 +-
basis/dlists/dlists-docs.factor | 10 ++-
basis/dlists/dlists-tests.factor | 9 ---
basis/dlists/dlists.factor | 74 +++++++++----------
basis/search-deques/search-deques-docs.factor | 10 +--
.../search-deques/search-deques-tests.factor | 4 +-
basis/search-deques/search-deques.factor | 7 +-
12 files changed, 72 insertions(+), 91 deletions(-)
diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor
index b01a835b4a..a6afc4b243 100644
--- a/basis/compiler/compiler.factor
+++ b/basis/compiler/compiler.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces arrays sequences io debugger
-words fry continuations vocabs assocs dlists definitions math
-threads graphs generic combinators deques search-deques
+words fry continuations vocabs assocs dlists definitions
+math threads graphs generic combinators deques search-deques
prettyprint io stack-checker stack-checker.state
stack-checker.inlining compiler.errors compiler.units
compiler.tree.builder compiler.tree.optimizer
diff --git a/basis/compiler/tree/dead-code/liveness/liveness.factor b/basis/compiler/tree/dead-code/liveness/liveness.factor
index 08bfde55b2..44b71935c8 100644
--- a/basis/compiler/tree/dead-code/liveness/liveness.factor
+++ b/basis/compiler/tree/dead-code/liveness/liveness.factor
@@ -1,8 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors namespaces assocs deques search-deques
-kernel sequences sequences.deep words sets stack-checker.branches
-compiler.tree compiler.tree.def-use compiler.tree.combinators ;
+dlists kernel sequences sequences.deep words sets
+stack-checker.branches compiler.tree compiler.tree.def-use
+compiler.tree.combinators ;
IN: compiler.tree.dead-code.liveness
SYMBOL: work-list
diff --git a/basis/compiler/tree/def-use/def-use.factor b/basis/compiler/tree/def-use/def-use.factor
index 9be9f13043..705f44eeb6 100644
--- a/basis/compiler/tree/def-use/def-use.factor
+++ b/basis/compiler/tree/def-use/def-use.factor
@@ -18,12 +18,16 @@ TUPLE: definition value node uses ;
swap >>node
V{ } clone >>uses ;
+ERROR: no-def-error value ;
+
: def-of ( value -- definition )
- def-use get at* [ "No def" throw ] unless ;
+ dup def-use get at* [ nip ] [ no-def-error ] if ;
+
+ERROR: multiple-defs-error ;
: def-value ( node value -- )
def-use get 2dup key? [
- "Multiple defs" throw
+ multiple-defs-error
] [
[ [ <definition> ] keep ] dip set-at
] if ;
diff --git a/basis/compiler/tree/recursive/recursive.factor b/basis/compiler/tree/recursive/recursive.factor
index d257cd6600..2e40693e69 100644
--- a/basis/compiler/tree/recursive/recursive.factor
+++ b/basis/compiler/tree/recursive/recursive.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs arrays namespaces accessors sequences deques
-search-deques compiler.tree compiler.tree.combinators ;
+search-deques dlists compiler.tree compiler.tree.combinators ;
IN: compiler.tree.recursive
! Collect label info
diff --git a/basis/deques/deques-docs.factor b/basis/deques/deques-docs.factor
index 58f077ed1e..e747bd9316 100644
--- a/basis/deques/deques-docs.factor
+++ b/basis/deques/deques-docs.factor
@@ -4,7 +4,7 @@ IN: deques
HELP: deque-empty?
{ $values { "deque" deque } { "?" "a boolean" } }
-{ $description "Returns true if a deque is empty." }
+{ $contract "Returns true if a deque is empty." }
{ $notes "This operation is O(1)." } ;
HELP: clear-deque
@@ -12,12 +12,6 @@ HELP: clear-deque
{ "deque" deque } }
{ $description "Removes all elements from a deque." } ;
-HELP: deque-length
-{ $values
- { "deque" deque }
- { "n" integer } }
-{ $description "Returns the number of elements in a deque." } ;
-
HELP: deque-member?
{ $values
{ "value" object } { "deque" deque }
@@ -31,7 +25,7 @@ HELP: push-front
HELP: push-front*
{ $values { "obj" object } { "deque" deque } { "node" "a node" } }
-{ $description "Push the object onto the front of the deque and return the newly created node." }
+{ $contract "Push the object onto the front of the deque and return the newly created node." }
{ $notes "This operation is O(1)." } ;
HELP: push-back
@@ -41,7 +35,7 @@ HELP: push-back
HELP: push-back*
{ $values { "obj" object } { "deque" deque } { "node" "a node" } }
-{ $description "Push the object onto the back of the deque and return the newly created node." }
+{ $contract "Push the object onto the back of the deque and return the newly created node." }
{ $notes "This operation is O(1)." } ;
HELP: push-all-back
@@ -56,7 +50,7 @@ HELP: push-all-front
HELP: peek-front
{ $values { "deque" deque } { "obj" object } }
-{ $description "Returns the object at the front of the deque." } ;
+{ $contract "Returns the object at the front of the deque." } ;
HELP: pop-front
{ $values { "deque" deque } { "obj" object } }
@@ -65,12 +59,12 @@ HELP: pop-front
HELP: pop-front*
{ $values { "deque" deque } }
-{ $description "Pop the object off the front of the deque." }
+{ $contract "Pop the object off the front of the deque." }
{ $notes "This operation is O(1)." } ;
HELP: peek-back
{ $values { "deque" deque } { "obj" object } }
-{ $description "Returns the object at the back of the deque." } ;
+{ $contract "Returns the object at the back of the deque." } ;
HELP: pop-back
{ $values { "deque" deque } { "obj" object } }
@@ -79,13 +73,13 @@ HELP: pop-back
HELP: pop-back*
{ $values { "deque" deque } }
-{ $description "Pop the object off the back of the deque." }
+{ $contract "Pop the object off the back of the deque." }
{ $notes "This operation is O(1)." } ;
HELP: delete-node
{ $values
{ "node" object } { "deque" deque } }
-{ $description "Deletes the node from the deque." } ;
+{ $contract "Deletes the node from the deque." } ;
HELP: deque
{ $description "A data structure that has constant-time insertion and removal of elements at both ends." } ;
@@ -111,7 +105,7 @@ $nl
"Querying the deque:"
{ $subsection peek-front }
{ $subsection peek-back }
-{ $subsection deque-length }
+{ $subsection deque-empty? }
{ $subsection deque-member? }
"Adding and removing elements:"
{ $subsection push-front* }
@@ -123,7 +117,6 @@ $nl
{ $subsection delete-node }
{ $subsection node-value }
"Utility operations built in terms of the above:"
-{ $subsection deque-empty? }
{ $subsection push-front }
{ $subsection push-all-front }
{ $subsection push-back }
diff --git a/basis/deques/deques.factor b/basis/deques/deques.factor
index 1d86a3f1db..f4e68c214b 100644
--- a/basis/deques/deques.factor
+++ b/basis/deques/deques.factor
@@ -10,13 +10,10 @@ GENERIC: peek-back ( deque -- obj )
GENERIC: pop-front* ( deque -- )
GENERIC: pop-back* ( deque -- )
GENERIC: delete-node ( node deque -- )
-GENERIC: deque-length ( deque -- n )
GENERIC: deque-member? ( value deque -- ? )
GENERIC: clear-deque ( deque -- )
GENERIC: node-value ( node -- value )
-
-: deque-empty? ( deque -- ? )
- deque-length zero? ;
+GENERIC: deque-empty? ( deque -- ? )
: push-front ( obj deque -- )
push-front* drop ;
diff --git a/basis/dlists/dlists-docs.factor b/basis/dlists/dlists-docs.factor
index 557010cf7c..2ea5abf787 100644
--- a/basis/dlists/dlists-docs.factor
+++ b/basis/dlists/dlists-docs.factor
@@ -1,5 +1,5 @@
USING: help.markup help.syntax kernel quotations
-deques ;
+deques search-deques hashtables ;
IN: dlists
ARTICLE: "dlists" "Double-linked lists"
@@ -18,10 +18,16 @@ $nl
{ $subsection dlist-contains? }
"Deleting a node matching a predicate:"
{ $subsection delete-node-if* }
-{ $subsection delete-node-if } ;
+{ $subsection delete-node-if }
+"Search deque implementation:"
+{ $subsection <hashed-dlist> } ;
ABOUT: "dlists"
+HELP: <hashed-dlist> ( -- search-deque )
+{ $values { "search-deque" search-deque } }
+{ $description "Creates a new " { $link search-deque } " backed by a " { $link dlist } ", with a " { $link hashtable } " for fast membership tests." } ;
+
HELP: dlist-find
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, until it outputs a true value or the end of the " { $link dlist } " is reached. Outputs either the object it found or " { $link f } ", and a boolean which is true if an object is found." }
diff --git a/basis/dlists/dlists-tests.factor b/basis/dlists/dlists-tests.factor
index 92b141dca8..613fe56542 100644
--- a/basis/dlists/dlists-tests.factor
+++ b/basis/dlists/dlists-tests.factor
@@ -52,15 +52,6 @@ IN: dlists.tests
[ 1 ] [ <dlist> 1 over push-back [ 1 = ] delete-node-if ] unit-test
[ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop deque-empty? ] unit-test
[ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop deque-empty? ] unit-test
-[ 0 ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop deque-length ] unit-test
-[ 1 ] [ <dlist> 1 over push-back 2 over push-back dup [ 1 = ] delete-node-if drop deque-length ] unit-test
-[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 1 = ] delete-node-if drop deque-length ] unit-test
-[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 2 = ] delete-node-if drop deque-length ] unit-test
-[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 3 = ] delete-node-if drop deque-length ] unit-test
-
-[ 0 ] [ <dlist> deque-length ] unit-test
-[ 1 ] [ <dlist> 1 over push-front deque-length ] unit-test
-[ 0 ] [ <dlist> 1 over push-front dup pop-front* deque-length ] unit-test
[ t ] [ <dlist> 4 over push-back 5 over push-back [ obj>> 4 = ] dlist-find-node drop class dlist-node = ] unit-test
[ t ] [ <dlist> 4 over push-back 5 over push-back [ obj>> 5 = ] dlist-find-node drop class dlist-node = ] unit-test
diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor
index 5072c3edfd..bd0e0f28cf 100644
--- a/basis/dlists/dlists.factor
+++ b/basis/dlists/dlists.factor
@@ -2,51 +2,57 @@
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel math sequences accessors deques
-summary ;
+search-deques summary hashtables ;
IN: dlists
-TUPLE: dlist front back length ;
-
-: <dlist> ( -- obj )
- dlist new
- 0 >>length ;
-
-M: dlist deque-length length>> ;
-
<PRIVATE
-TUPLE: dlist-node obj prev next ;
+MIXIN: ?dlist-node
+
+INSTANCE: f ?dlist-node
+
+TUPLE: dlist-node obj { prev ?dlist-node } { next ?dlist-node } ;
+
+INSTANCE: dlist-node ?dlist-node
C: <dlist-node> dlist-node
+PRIVATE>
+
+TUPLE: dlist
+{ front ?dlist-node }
+{ back ?dlist-node } ;
+
+: <dlist> ( -- obj )
+ dlist new ; inline
+
+: <hashed-dlist> ( -- search-deque )
+ 20 <hashtable> <dlist> <search-deque> ;
+
+M: dlist deque-empty? front>> not ;
+
M: dlist-node node-value obj>> ;
-: inc-length ( dlist -- )
- [ 1+ ] change-length drop ; inline
-
-: dec-length ( dlist -- )
- [ 1- ] change-length drop ; inline
-
: set-prev-when ( dlist-node dlist-node/f -- )
- [ (>>prev) ] [ drop ] if* ;
+ [ (>>prev) ] [ drop ] if* ; inline
: set-next-when ( dlist-node dlist-node/f -- )
- [ (>>next) ] [ drop ] if* ;
+ [ (>>next) ] [ drop ] if* ; inline
: set-next-prev ( dlist-node -- )
- dup next>> set-prev-when ;
+ dup next>> set-prev-when ; inline
: normalize-front ( dlist -- )
- dup back>> [ f >>front ] unless drop ;
+ dup back>> [ f >>front ] unless drop ; inline
: normalize-back ( dlist -- )
- dup front>> [ f >>back ] unless drop ;
+ dup front>> [ f >>back ] unless drop ; inline
: set-back-to-front ( dlist -- )
- dup back>> [ dup front>> >>back ] unless drop ;
+ dup back>> [ dup front>> >>back ] unless drop ; inline
: set-front-to-back ( dlist -- )
- dup front>> [ dup back>> >>front ] unless drop ;
+ dup front>> [ dup back>> >>front ] unless drop ; inline
: (dlist-find-node) ( dlist-node quot: ( node -- ? ) -- node/f ? )
over [
@@ -62,22 +68,20 @@ M: dlist-node node-value obj>> ;
: unlink-node ( dlist-node -- )
dup prev>> over next>> set-prev-when
- dup next>> swap prev>> set-next-when ;
+ dup next>> swap prev>> set-next-when ; inline
PRIVATE>
M: dlist push-front* ( obj dlist -- dlist-node )
[ front>> f swap <dlist-node> dup dup set-next-prev ] keep
[ (>>front) ] keep
- [ set-back-to-front ] keep
- inc-length ;
+ set-back-to-front ;
M: dlist push-back* ( obj dlist -- dlist-node )
[ back>> f <dlist-node> ] keep
[ back>> set-next-when ] 2keep
[ (>>back) ] 2keep
- [ set-front-to-back ] keep
- inc-length ;
+ set-front-to-back ;
ERROR: empty-dlist ;
@@ -88,31 +92,27 @@ M: dlist peek-front ( dlist -- obj )
front>> [ obj>> ] [ empty-dlist ] if* ;
M: dlist pop-front* ( dlist -- )
- dup front>> [ empty-dlist ] unless
[
- dup front>>
+ dup front>> [ empty-dlist ] unless*
dup next>>
f rot (>>next)
f over set-prev-when
swap (>>front)
] keep
- [ normalize-back ] keep
- dec-length ;
+ normalize-back ;
M: dlist peek-back ( dlist -- obj )
back>> [ obj>> ] [ empty-dlist ] if* ;
M: dlist pop-back* ( dlist -- )
- dup back>> [ empty-dlist ] unless
[
- dup back>>
+ dup back>> [ empty-dlist ] unless*
dup prev>>
f rot (>>prev)
f over set-next-when
swap (>>back)
] keep
- [ normalize-front ] keep
- dec-length ;
+ normalize-front ;
: dlist-find ( dlist quot -- obj/f ? )
[ obj>> ] prepose
@@ -128,7 +128,7 @@ M: dlist delete-node ( dlist-node dlist -- )
{
{ [ 2dup front>> eq? ] [ nip pop-front* ] }
{ [ 2dup back>> eq? ] [ nip pop-back* ] }
- [ dec-length unlink-node ]
+ [ drop unlink-node ]
} cond ;
: delete-node-if* ( dlist quot -- obj/f ? )
diff --git a/basis/search-deques/search-deques-docs.factor b/basis/search-deques/search-deques-docs.factor
index fef770b0f8..fe0ce7c157 100644
--- a/basis/search-deques/search-deques-docs.factor
+++ b/basis/search-deques/search-deques-docs.factor
@@ -1,21 +1,15 @@
IN: search-deques
-USING: help.markup help.syntax kernel dlists hashtables
+USING: help.markup help.syntax kernel hashtables
deques assocs ;
ARTICLE: "search-deques" "Search deques"
"A search deque is a data structure with constant-time insertion and removal of elements at both ends, and constant-time membership tests. Inserting an element more than once has no effect. Search deques implement all deque operations in terms of an underlying deque, and membership testing with " { $link deque-member? } " is implemented with an underlying assoc. Search deques are defined in the " { $vocab-link "search-deques" } " vocabulary."
$nl
"Creating a search deque:"
-{ $subsection <search-deque> }
-"Default implementation:"
-{ $subsection <hashed-dlist> } ;
+{ $subsection <search-deque> } ;
ABOUT: "search-deques"
HELP: <search-deque> ( assoc deque -- search-deque )
{ $values { "assoc" assoc } { "deque" deque } { "search-deque" search-deque } }
{ $description "Creates a new " { $link search-deque } "." } ;
-
-HELP: <hashed-dlist> ( -- search-deque )
-{ $values { "search-deque" search-deque } }
-{ $description "Creates a new " { $link search-deque } " backed by a " { $link dlist } ", with a " { $link hashtable } " for fast membership tests." } ;
diff --git a/basis/search-deques/search-deques-tests.factor b/basis/search-deques/search-deques-tests.factor
index cf2837a84c..7c40c60f7a 100644
--- a/basis/search-deques/search-deques-tests.factor
+++ b/basis/search-deques/search-deques-tests.factor
@@ -1,6 +1,6 @@
IN: search-deques.tests
USING: search-deques tools.test namespaces
-kernel sequences words deques vocabs ;
+kernel sequences words deques vocabs dlists ;
<hashed-dlist> "h" set
@@ -15,13 +15,11 @@ kernel sequences words deques vocabs ;
[ t ] [ "1" get "2" get eq? ] unit-test
[ t ] [ "2" get "3" get eq? ] unit-test
-[ 3 ] [ "h" get deque-length ] unit-test
[ t ] [ 7 "h" get deque-member? ] unit-test
[ 3 ] [ "1" get node-value ] unit-test
[ ] [ "1" get "h" get delete-node ] unit-test
-[ 2 ] [ "h" get deque-length ] unit-test
[ 1 ] [ "h" get pop-back ] unit-test
[ 7 ] [ "h" get pop-back ] unit-test
diff --git a/basis/search-deques/search-deques.factor b/basis/search-deques/search-deques.factor
index 8e5506090c..5546a9766d 100644
--- a/basis/search-deques/search-deques.factor
+++ b/basis/search-deques/search-deques.factor
@@ -1,16 +1,13 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel assocs deques dlists hashtables ;
+USING: accessors kernel assocs deques ;
IN: search-deques
TUPLE: search-deque assoc deque ;
C: <search-deque> search-deque
-: <hashed-dlist> ( -- search-deque )
- 0 <hashtable> <dlist> <search-deque> ;
-
-M: search-deque deque-length deque>> deque-length ;
+M: search-deque deque-empty? deque>> deque-empty? ;
M: search-deque peek-front deque>> peek-front ;
From 9c84ad894412a7b1d9c46914b387a48a4dda1489 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 05:59:14 -0600
Subject: [PATCH 108/157] Unrolled lists
---
basis/dlists/dlists-docs.factor | 5 +-
.../unrolled-lists/unrolled-lists-docs.factor | 22 +++
.../unrolled-lists-tests.factor | 130 ++++++++++++++++
basis/unrolled-lists/unrolled-lists.factor | 140 ++++++++++++++++++
4 files changed, 296 insertions(+), 1 deletion(-)
create mode 100644 basis/unrolled-lists/unrolled-lists-docs.factor
create mode 100644 basis/unrolled-lists/unrolled-lists-tests.factor
create mode 100644 basis/unrolled-lists/unrolled-lists.factor
diff --git a/basis/dlists/dlists-docs.factor b/basis/dlists/dlists-docs.factor
index 2ea5abf787..5a19936a97 100644
--- a/basis/dlists/dlists-docs.factor
+++ b/basis/dlists/dlists-docs.factor
@@ -24,7 +24,10 @@ $nl
ABOUT: "dlists"
-HELP: <hashed-dlist> ( -- search-deque )
+HELP: <dlist>
+{ $description "Creates a new double-linked list." } ;
+
+HELP: <hashed-dlist>
{ $values { "search-deque" search-deque } }
{ $description "Creates a new " { $link search-deque } " backed by a " { $link dlist } ", with a " { $link hashtable } " for fast membership tests." } ;
diff --git a/basis/unrolled-lists/unrolled-lists-docs.factor b/basis/unrolled-lists/unrolled-lists-docs.factor
new file mode 100644
index 0000000000..387bb3dc7b
--- /dev/null
+++ b/basis/unrolled-lists/unrolled-lists-docs.factor
@@ -0,0 +1,22 @@
+IN: unrolled-lists
+USING: help.markup help.syntax hashtables search-deques dlists
+deques ;
+
+HELP: unrolled-list
+{ $class-description "The class of unrolled lists." } ;
+
+HELP: <unrolled-list>
+{ $values { "list" unrolled-list } }
+{ $description "Creates a new unrolled list." } ;
+
+HELP: <hashed-unrolled-list>
+{ $values { "search-deque" search-deque } }
+{ $description "Creates a new " { $link search-deque } " backed by an " { $link unrolled-list } ", with a " { $link hashtable } " for fast membership tests." } ;
+
+ARTICLE: "unrolled-lists" "Unrolled lists"
+"The " { $vocab-link "unrolled-lists" } " vocabulary provides an implementation of the " { $link deque } " protocol with constant time insertion and removal at both ends, and lower memory overhead than a " { $link dlist } " due to packing 32 elements per every node. The one tradeoff is that unlike dlists, " { $link delete-node } " is not supported for unrolled lists."
+{ $subsection unrolled-list }
+{ $subsection <unrolled-list> }
+{ $subsection <hashed-unrolled-list> } ;
+
+ABOUT: "unrolled-lists"
diff --git a/basis/unrolled-lists/unrolled-lists-tests.factor b/basis/unrolled-lists/unrolled-lists-tests.factor
new file mode 100644
index 0000000000..89eb1cdebd
--- /dev/null
+++ b/basis/unrolled-lists/unrolled-lists-tests.factor
@@ -0,0 +1,130 @@
+USING: unrolled-lists tools.test deques kernel sequences
+random prettyprint grouping ;
+IN: unrolled-lists.tests
+
+[ 1 ] [ <unrolled-list> 1 over push-front pop-front ] unit-test
+[ 1 ] [ <unrolled-list> 1 over push-front pop-back ] unit-test
+[ 1 ] [ <unrolled-list> 1 over push-back pop-front ] unit-test
+[ 1 ] [ <unrolled-list> 1 over push-back pop-back ] unit-test
+
+[ 1 2 ] [
+ <unrolled-list> 1 over push-back 2 over push-back
+ [ pop-front ] [ pop-front ] bi
+] unit-test
+
+[ 2 1 ] [
+ <unrolled-list> 1 over push-back 2 over push-back
+ [ pop-back ] [ pop-back ] bi
+] unit-test
+
+[ 1 2 3 ] [
+ <unrolled-list>
+ 1 over push-back
+ 2 over push-back
+ 3 over push-back
+ [ pop-front ] [ pop-front ] [ pop-front ] tri
+] unit-test
+
+[ 3 2 1 ] [
+ <unrolled-list>
+ 1 over push-back
+ 2 over push-back
+ 3 over push-back
+ [ pop-back ] [ pop-back ] [ pop-back ] tri
+] unit-test
+
+[ { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 } ] [
+ <unrolled-list>
+ 32 [ over push-front ] each
+ 32 [ dup pop-back ] replicate
+ nip
+] unit-test
+
+[ { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 } ] [
+ <unrolled-list>
+ 32 [ over push-front ] each
+ 32 [ dup pop-front ] replicate reverse
+ nip
+] unit-test
+
+[ t ] [
+ <unrolled-list>
+ 1000 [ 1000 random ] replicate
+ [ [ over push-front ] each ]
+ [ [ dup pop-back ] replicate ]
+ [ ]
+ tri
+ =
+ nip
+] unit-test
+
+[ t ] [
+ <unrolled-list>
+ 1000 [ 1000 random ] replicate
+ [
+ 10 group [
+ [ [ over push-front ] each ]
+ [ [ dup pop-back ] replicate ]
+ bi
+ ] map concat
+ ] keep
+ =
+ nip
+] unit-test
+
+[ t ] [ <unrolled-list> deque-empty? ] unit-test
+
+[ t ] [
+ <unrolled-list>
+ 1 over push-front
+ dup pop-front*
+ deque-empty?
+] unit-test
+
+[ t ] [
+ <unrolled-list>
+ 1 over push-back
+ dup pop-front*
+ deque-empty?
+] unit-test
+
+[ t ] [
+ <unrolled-list>
+ 1 over push-front
+ dup pop-back*
+ deque-empty?
+] unit-test
+
+[ t ] [
+ <unrolled-list>
+ 1 over push-back
+ dup pop-back*
+ deque-empty?
+] unit-test
+
+[ t ] [
+ <unrolled-list>
+ 21 over push-front
+ 22 over push-front
+ 25 over push-front
+ 26 over push-front
+ dup pop-back 21 assert=
+ 28 over push-front
+ dup pop-back 22 assert=
+ 29 over push-front
+ dup pop-back 25 assert=
+ 24 over push-front
+ dup pop-back 26 assert=
+ 23 over push-front
+ dup pop-back 28 assert=
+ dup pop-back 29 assert=
+ dup pop-back 24 assert=
+ 17 over push-front
+ dup pop-back 23 assert=
+ 27 over push-front
+ dup pop-back 17 assert=
+ 30 over push-front
+ dup pop-back 27 assert=
+ dup pop-back 30 assert=
+ deque-empty?
+] unit-test
diff --git a/basis/unrolled-lists/unrolled-lists.factor b/basis/unrolled-lists/unrolled-lists.factor
new file mode 100644
index 0000000000..27f7175315
--- /dev/null
+++ b/basis/unrolled-lists/unrolled-lists.factor
@@ -0,0 +1,140 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays math kernel accessors sequences sequences.private
+deques search-deques hashtables ;
+IN: unrolled-lists
+
+: unroll-factor 32 ; inline
+
+<PRIVATE
+
+MIXIN: ?node
+INSTANCE: f ?node
+TUPLE: node { data array } { prev ?node } { next ?node } ;
+INSTANCE: node ?node
+
+PRIVATE>
+
+TUPLE: unrolled-list
+{ front ?node } { front-pos fixnum }
+{ back ?node } { back-pos fixnum } ;
+
+: <unrolled-list> ( -- list )
+ unrolled-list new
+ unroll-factor >>back-pos ; inline
+
+: <hashed-unrolled-list> ( -- list )
+ 20 <hashtable> <unrolled-list> <search-deque> ;
+
+ERROR: empty-unrolled-list list ;
+
+<PRIVATE
+
+M: unrolled-list deque-empty?
+ dup [ front>> ] [ back>> ] bi dup [
+ eq? [ [ front-pos>> ] [ back-pos>> ] bi eq? ] [ drop f ] if
+ ] [ 3drop t ] if ;
+
+M: unrolled-list clear-deque
+ f >>front
+ 0 >>front-pos
+ f >>back
+ unroll-factor >>back-pos
+ drop ;
+
+: <front-node> ( elt front -- node )
+ [
+ unroll-factor 0 <array>
+ [ unroll-factor 1- swap set-nth ] keep f
+ ] dip [ node boa dup ] keep
+ dup [ (>>prev) ] [ 2drop ] if ; inline
+
+: normalize-back ( list -- )
+ dup back>> [
+ dup prev>> [ drop ] [ swap front>> >>prev ] if
+ ] [ dup front>> >>back ] if* drop ; inline
+
+: push-front/new ( elt list -- )
+ unroll-factor 1- >>front-pos
+ [ <front-node> ] change-front
+ normalize-back ; inline
+
+: push-front/existing ( elt list front -- )
+ [ [ 1- ] change-front-pos ] dip
+ [ front-pos>> ] [ data>> ] bi* set-nth-unsafe ; inline
+
+M: unrolled-list push-front*
+ dup [ front>> ] [ front-pos>> 0 eq? not ] bi
+ [ drop ] [ and ] 2bi
+ [ push-front/existing ] [ drop push-front/new ] if f ;
+
+M: unrolled-list peek-front
+ dup front>>
+ [ [ front-pos>> ] dip data>> nth-unsafe ]
+ [ empty-unrolled-list ]
+ if* ;
+
+: pop-front/new ( list front -- )
+ [ 0 >>front-pos ] dip
+ [ f ] change-next drop dup [ f >>prev ] when >>front
+ dup front>> [ normalize-back ] [ f >>back drop ] if ; inline
+
+: pop-front/existing ( list front -- )
+ [ dup front-pos>> ] [ data>> ] bi* [ 0 ] 2dip set-nth-unsafe
+ [ 1+ ] change-front-pos
+ drop ; inline
+
+M: unrolled-list pop-front*
+ dup front>> [ empty-unrolled-list ] unless*
+ over front-pos>> unroll-factor 1- eq?
+ [ pop-front/new ] [ pop-front/existing ] if ;
+
+: <back-node> ( elt back -- node )
+ [
+ unroll-factor 0 <array> [ set-first ] keep
+ ] dip [ f node boa dup ] keep
+ dup [ (>>next) ] [ 2drop ] if ; inline
+
+: normalize-front ( list -- )
+ dup front>> [
+ dup next>> [ drop ] [ swap back>> >>next ] if
+ ] [ dup back>> >>front ] if* drop ; inline
+
+: push-back/new ( elt list -- )
+ 1 >>back-pos
+ [ <back-node> ] change-back
+ normalize-front ; inline
+
+: push-back/existing ( elt list back -- )
+ [ [ 1+ ] change-back-pos ] dip
+ [ back-pos>> 1- ] [ data>> ] bi* set-nth-unsafe ; inline
+
+M: unrolled-list push-back*
+ dup [ back>> ] [ back-pos>> unroll-factor eq? not ] bi
+ [ drop ] [ and ] 2bi
+ [ push-back/existing ] [ drop push-back/new ] if f ;
+
+M: unrolled-list peek-back
+ dup back>>
+ [ [ back-pos>> 1- ] dip data>> nth-unsafe ]
+ [ empty-unrolled-list ]
+ if* ;
+
+: pop-back/new ( list back -- )
+ [ unroll-factor >>back-pos ] dip
+ [ f ] change-prev drop dup [ f >>next ] when >>back
+ dup back>> [ normalize-front ] [ f >>front drop ] if ; inline
+
+: pop-back/existing ( list back -- )
+ [ [ 1- ] change-back-pos ] dip
+ [ dup back-pos>> ] [ data>> ] bi* [ 0 ] 2dip set-nth-unsafe
+ drop ; inline
+
+M: unrolled-list pop-back*
+ dup back>> [ empty-unrolled-list ] unless*
+ over back-pos>> 1 eq?
+ [ pop-back/new ] [ pop-back/existing ] if ;
+
+PRIVATE>
+
+INSTANCE: unrolled-list deque
From 99fd539b01c23d39cefae2b0c1b589834d5bd8a2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 05:59:38 -0600
Subject: [PATCH 109/157] Rename io.streams.string:null to null-encoding
---
core/io/streams/string/string.factor | 51 +++++++++++++++-------------
1 file changed, 28 insertions(+), 23 deletions(-)
diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor
index b2b75509e9..184b5e1c15 100644
--- a/core/io/streams/string/string.factor
+++ b/core/io/streams/string/string.factor
@@ -5,6 +5,33 @@ strings generic splitting continuations destructors
io.streams.plain io.encodings math.order growable ;
IN: io.streams.string
+<PRIVATE
+
+: harden-as ( seq growble-exemplar -- newseq )
+ underlying>> like ;
+
+: growable-read-until ( growable n -- str )
+ >fixnum dupd tail-slice swap harden-as dup reverse-here ;
+
+SINGLETON: null-encoding
+
+M: null-encoding decode-char drop stream-read1 ;
+
+: format-column ( seq ? -- seq )
+ [
+ [ 0 [ length max ] reduce ] keep
+ swap [ CHAR: \s pad-right ] curry map
+ ] unless ;
+
+: map-last ( seq quot -- seq )
+ >r dup length <reversed> [ zero? ] r> compose 2map ; inline
+
+: format-table ( table -- seq )
+ flip [ format-column ] map-last
+ flip [ " " join ] map ;
+
+PRIVATE>
+
M: growable dispose drop ;
M: growable stream-write1 push ;
@@ -20,12 +47,6 @@ M: growable stream-flush drop ;
M: growable stream-read1 [ f ] [ pop ] if-empty ;
-: harden-as ( seq growble-exemplar -- newseq )
- underlying>> like ;
-
-: growable-read-until ( growable n -- str )
- >fixnum dupd tail-slice swap harden-as dup reverse-here ;
-
: find-last-sep ( seq seps -- n )
swap [ memq? ] curry find-last drop ;
@@ -50,30 +71,14 @@ M: growable stream-read
M: growable stream-read-partial
stream-read ;
-SINGLETON: null
-M: null decode-char drop stream-read1 ;
-
: <string-reader> ( str -- stream )
- >sbuf dup reverse-here null <decoder> ;
+ >sbuf dup reverse-here null-encoding <decoder> ;
: with-string-reader ( str quot -- )
>r <string-reader> r> with-input-stream ; inline
INSTANCE: growable plain-writer
-: format-column ( seq ? -- seq )
- [
- [ 0 [ length max ] reduce ] keep
- swap [ CHAR: \s pad-right ] curry map
- ] unless ;
-
-: map-last ( seq quot -- seq )
- >r dup length <reversed> [ zero? ] r> compose 2map ; inline
-
-: format-table ( table -- seq )
- flip [ format-column ] map-last
- flip [ " " join ] map ;
-
M: plain-writer stream-write-table
[ drop format-table [ print ] each ] with-output-stream* ;
From 93e9e341756bd7efe12cc2dbdfda1a718031ef12 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 06:02:13 -0600
Subject: [PATCH 110/157] Add $maybe markup element
---
basis/alarms/alarms-docs.factor | 2 +-
basis/concurrency/locks/locks-docs.factor | 6 +++---
.../concurrency/promises/promises-docs.factor | 2 +-
.../semaphores/semaphores-docs.factor | 4 ++--
basis/help/markup/markup.factor | 9 ++++++++-
basis/html/templates/chloe/chloe-docs.factor | 2 +-
basis/http/http-docs.factor | 2 +-
.../servers/connection/connection-docs.factor | 4 ++--
basis/io/timeouts/timeouts-docs.factor | 4 ++--
basis/math/intervals/intervals-docs.factor | 20 +++++++++----------
basis/threads/threads-docs.factor | 4 ++--
basis/ui/commands/commands-docs.factor | 4 ++--
basis/ui/gadgets/gadgets-docs.factor | 4 ++--
.../gadgets/scrollers/scrollers-docs.factor | 2 +-
basis/ui/gadgets/sliders/sliders-docs.factor | 4 ++--
basis/ui/gadgets/worlds/worlds-docs.factor | 2 +-
basis/ui/gestures/gestures-docs.factor | 2 +-
basis/ui/operations/operations-docs.factor | 6 +++---
basis/ui/ui-docs.factor | 2 +-
basis/urls/urls-docs.factor | 6 +++---
core/effects/effects-docs.factor | 2 +-
core/generic/generic-docs.factor | 2 +-
core/lexer/lexer-docs.factor | 6 +++---
core/slots/slots-docs.factor | 2 +-
24 files changed, 55 insertions(+), 48 deletions(-)
diff --git a/basis/alarms/alarms-docs.factor b/basis/alarms/alarms-docs.factor
index dac8b72dd5..2d494afca3 100644
--- a/basis/alarms/alarms-docs.factor
+++ b/basis/alarms/alarms-docs.factor
@@ -5,7 +5,7 @@ HELP: alarm
{ $class-description "An alarm. Can be passed to " { $link cancel-alarm } "." } ;
HELP: add-alarm
-{ $values { "quot" quotation } { "time" timestamp } { "frequency" "a " { $link duration } " or " { $link f } } { "alarm" alarm } }
+{ $values { "quot" quotation } { "time" timestamp } { "frequency" { $maybe duration } } { "alarm" alarm } }
{ $description "Creates and registers an alarm. If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ;
HELP: later
diff --git a/basis/concurrency/locks/locks-docs.factor b/basis/concurrency/locks/locks-docs.factor
index a3cf2fc782..b74dcec384 100644
--- a/basis/concurrency/locks/locks-docs.factor
+++ b/basis/concurrency/locks/locks-docs.factor
@@ -14,7 +14,7 @@ HELP: <reentrant-lock>
{ $description "Creates a reentrant lock." } ;
HELP: with-lock-timeout
-{ $values { "lock" lock } { "timeout" "a " { $link duration } " or " { $link f } } { "quot" quotation } }
+{ $values { "lock" lock } { "timeout" { $maybe duration } } { "quot" quotation } }
{ $description "Calls the quotation, ensuring that only one thread executes with the lock held at a time. If another thread is holding the lock, blocks until the thread releases the lock." }
{ $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ;
@@ -36,7 +36,7 @@ HELP: rw-lock
{ $class-description "The class of reader/writer locks." } ;
HELP: with-read-lock-timeout
-{ $values { "lock" lock } { "timeout" "a " { $link duration } " or " { $link f } } { "quot" quotation } }
+{ $values { "lock" lock } { "timeout" { $maybe duration } } { "quot" quotation } }
{ $description "Calls the quotation, ensuring that no other thread is holding a write lock at the same time. If another thread is holding a write lock, blocks until the thread releases the lock." }
{ $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ;
@@ -45,7 +45,7 @@ HELP: with-read-lock
{ $description "Calls the quotation, ensuring that no other thread is holding a write lock at the same time. If another thread is holding a write lock, blocks until the thread releases the lock." } ;
HELP: with-write-lock-timeout
-{ $values { "lock" lock } { "timeout" "a " { $link duration } " or " { $link f } } { "quot" quotation } }
+{ $values { "lock" lock } { "timeout" { $maybe duration } } { "quot" quotation } }
{ $description "Calls the quotation, ensuring that no other thread is holding a read or write lock at the same time. If another thread is holding a read or write lock, blocks until the thread releases the lock." }
{ $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ;
diff --git a/basis/concurrency/promises/promises-docs.factor b/basis/concurrency/promises/promises-docs.factor
index 6a4a2bf8d6..be7a8cf65b 100644
--- a/basis/concurrency/promises/promises-docs.factor
+++ b/basis/concurrency/promises/promises-docs.factor
@@ -12,7 +12,7 @@ HELP: promise-fulfilled?
{ $description "Tests if " { $link fulfill } " has previously been called on the promise, in which case " { $link ?promise } " will return immediately without blocking." } ;
HELP: ?promise-timeout
-{ $values { "promise" promise } { "timeout" "a " { $link duration } " or " { $link f } } { "result" object } }
+{ $values { "promise" promise } { "timeout" { $maybe duration } } { "result" object } }
{ $description "Waits for another thread to fulfill a promise, returning immediately if the promise has already been fulfilled. A timeout of " { $link f } " indicates that the thread may block indefinitely, otherwise it will wait up to " { $snippet "timeout" } " milliseconds." }
{ $errors "Throws an error if the timeout expires before the promise has been fulfilled." } ;
diff --git a/basis/concurrency/semaphores/semaphores-docs.factor b/basis/concurrency/semaphores/semaphores-docs.factor
index 379fd6a3a0..c86623f86f 100644
--- a/basis/concurrency/semaphores/semaphores-docs.factor
+++ b/basis/concurrency/semaphores/semaphores-docs.factor
@@ -9,7 +9,7 @@ HELP: <semaphore>
{ $description "Creates a counting semaphore with the specified initial count." } ;
HELP: acquire-timeout
-{ $values { "semaphore" semaphore } { "timeout" "a " { $link duration } " or " { $link f } } }
+{ $values { "semaphore" semaphore } { "timeout" { $maybe duration } } }
{ $description "If the semaphore has a non-zero count, decrements it and returns immediately. Otherwise, if the timeout is " { $link f } ", waits indefinitely for the semaphore to be released. If the timeout is not " { $link f } ", waits a certain period of time, and if the semaphore still has not been released, throws an error." }
{ $errors "Throws an error if the timeout expires before the semaphore is released." } ;
@@ -22,7 +22,7 @@ HELP: release
{ $description "Increments a semaphore's count. If the count was previously zero, any threads waiting on the semaphore are woken up." } ;
HELP: with-semaphore-timeout
-{ $values { "semaphore" semaphore } { "timeout" "a " { $link duration } " or " { $link f } } { "quot" quotation } }
+{ $values { "semaphore" semaphore } { "timeout" { $maybe duration } } { "quot" quotation } }
{ $description "Calls the quotation with the semaphore held." } ;
HELP: with-semaphore
diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor
index 1eae56cfcc..4410a6f780 100644
--- a/basis/help/markup/markup.factor
+++ b/basis/help/markup/markup.factor
@@ -234,7 +234,8 @@ ALIAS: $slot $snippet
] ($grid) ;
: a/an ( str -- str )
- first "aeiou" member? "an" "a" ? ;
+ [ first ] [ length ] bi 1 =
+ "afhilmnorsx" "aeiou" ? member? "an" "a" ? ;
GENERIC: ($instance) ( element -- )
@@ -244,8 +245,14 @@ M: word ($instance)
M: string ($instance)
dup a/an write bl $snippet ;
+M: f ($instance)
+ drop { f } $link ;
+
: $instance ( children -- ) first ($instance) ;
+: $maybe ( children -- )
+ $instance " or " print-element { f } $instance ;
+
: values-row ( seq -- seq )
unclip \ $snippet swap ?word-name 2array
swap dup first word? [ \ $instance prefix ] when 2array ;
diff --git a/basis/html/templates/chloe/chloe-docs.factor b/basis/html/templates/chloe/chloe-docs.factor
index 402b6e68a9..a0faecd743 100644
--- a/basis/html/templates/chloe/chloe-docs.factor
+++ b/basis/html/templates/chloe/chloe-docs.factor
@@ -14,7 +14,7 @@ HELP: required-attr
{ $errors "Throws an error if the attribute is not specified." } ;
HELP: optional-attr
-{ $values { "tag" tag } { "name" string } { "value" "a " { $link string } " or " { $link f } } }
+{ $values { "tag" tag } { "name" string } { "value" { $maybe string } } }
{ $description "Extracts an attribute from a tag." }
{ $notes "Outputs " { $link f } " if the attribute is not specified." } ;
diff --git a/basis/http/http-docs.factor b/basis/http/http-docs.factor
index 4db04f04aa..6fb5b73fad 100644
--- a/basis/http/http-docs.factor
+++ b/basis/http/http-docs.factor
@@ -81,7 +81,7 @@ HELP: delete-cookie
{ $side-effects "request/response" } ;
HELP: get-cookie
-{ $values { "request/response" "a " { $link request } " or a " { $link response } } { "name" string } { "cookie/f" "a " { $link cookie } " or " { $link f } } }
+{ $values { "request/response" "a " { $link request } " or a " { $link response } } { "name" string } { "cookie/f" { $maybe cookie } } }
{ $description "Gets a named cookie from a request or response." } ;
HELP: put-cookie
diff --git a/basis/io/servers/connection/connection-docs.factor b/basis/io/servers/connection/connection-docs.factor
index 22c40da3d7..b093840987 100644
--- a/basis/io/servers/connection/connection-docs.factor
+++ b/basis/io/servers/connection/connection-docs.factor
@@ -114,11 +114,11 @@ HELP: stop-this-server
{ $description "Stops the current threaded server, preventing it from accepting any more connections and returning to the caller of " { $link start-server } ". All client connections which have already been opened continue to be serviced." } ;
HELP: secure-port
-{ $values { "n" "an " { $link integer } " or " { $link f } } }
+{ $values { "n" { $maybe integer } } }
{ $description "Outputs the port number on which the current threaded server accepts secure socket connections. Outputs " { $link f } " if the current threaded server does not accept secure socket connections." }
{ $notes "Can only be used from the dynamic scope of a " { $link handle-client* } " call." } ;
HELP: insecure-port
-{ $values { "n" "an " { $link integer } " or " { $link f } } }
+{ $values { "n" { $maybe integer } } }
{ $description "Outputs the port number on which the current threaded server accepts ordinary socket connections. Outputs " { $link f } " if the current threaded server does not accept ordinary socket connections." }
{ $notes "Can only be used from the dynamic scope of a " { $link handle-client* } " call." } ;
diff --git a/basis/io/timeouts/timeouts-docs.factor b/basis/io/timeouts/timeouts-docs.factor
index b2927af362..fcaab80958 100644
--- a/basis/io/timeouts/timeouts-docs.factor
+++ b/basis/io/timeouts/timeouts-docs.factor
@@ -2,11 +2,11 @@ IN: io.timeouts
USING: help.markup help.syntax math kernel calendar ;
HELP: timeout
-{ $values { "obj" object } { "dt/f" "a " { $link duration } " or " { $link f } } }
+{ $values { "obj" object } { "dt/f" { $maybe duration } } }
{ $contract "Outputs an object's timeout." } ;
HELP: set-timeout
-{ $values { "dt/f" "a " { $link duration } " or " { $link f } } { "obj" object } }
+{ $values { "dt/f" { $maybe duration } } { "obj" object } }
{ $contract "Sets an object's timeout." } ;
HELP: cancel-operation
diff --git a/basis/math/intervals/intervals-docs.factor b/basis/math/intervals/intervals-docs.factor
index c5e5a6e7b8..5a96c7aceb 100644
--- a/basis/math/intervals/intervals-docs.factor
+++ b/basis/math/intervals/intervals-docs.factor
@@ -156,8 +156,8 @@ HELP: interval*
{ $description "Multiplies two intervals." } ;
HELP: interval-shift
-{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } }
-{ $description "Shifts " { $snippet "i1" } " to the left by " { $snippet "i2" } " bits. Outputs " { $link f } " if the endpoints of either " { $snippet "i1" } " or " { $snippet "i2" } " are not integers." } ;
+{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
+{ $description "Shifts " { $snippet "i1" } " to the left by " { $snippet "i2" } " bits. Outputs " { $link full-interval } " if the endpoints of either " { $snippet "i1" } " or " { $snippet "i2" } " are not integers." } ;
HELP: interval-max
{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
@@ -253,8 +253,8 @@ HELP: points>interval
;
HELP: interval-shift-safe
-{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } }
-{ $description "Shifts " { $snippet "i1" } " to the left by " { $snippet "i2" } " bits. Outputs " { $link f } " if the endpoints of either " { $snippet "i1" } " or " { $snippet "i2" } " are not integers, or if the endpoints of " { $snippet "i2" } " are so large that the resulting interval will consume too much memory." } ;
+{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
+{ $description "Shifts " { $snippet "i1" } " to the left by " { $snippet "i2" } " bits. Outputs " { $link full-interval } " if the endpoints of either " { $snippet "i1" } " or " { $snippet "i2" } " are not integers, or if the endpoints of " { $snippet "i2" } " are so large that the resulting interval will consume too much memory." } ;
HELP: incomparable
{ $description "Output value from " { $link interval<= } ", " { $link interval< } ", " { $link interval>= } " and " { $link interval> } " in the case where the result of the comparison is ambiguous." } ;
@@ -304,20 +304,20 @@ HELP: interval>points
{ $description "Outputs both endpoints of the interval." } ;
HELP: assume<
-{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } }
-{ $description "Outputs the interval consisting of points from " { $snippet "i1" } " which are less than all points in " { $snippet "i2" } ". If the resulting interval is empty, outputs " { $link f } "." } ;
+{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
+{ $description "Outputs the interval consisting of points from " { $snippet "i1" } " which are less than all points in " { $snippet "i2" } "." } ;
HELP: assume<=
-{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } }
-{ $description "Outputs the interval consisting of points from " { $snippet "i1" } " which are less or equal to all points in " { $snippet "i2" } ". If the resulting interval is empty, outputs " { $link f } "." } ;
+{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
+{ $description "Outputs the interval consisting of points from " { $snippet "i1" } " which are less or equal to all points in " { $snippet "i2" } "." } ;
HELP: assume>
{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } }
{ $description "Outputs the interval consisting of points from " { $snippet "i1" } " which are greater than all points in " { $snippet "i2" } ". If the resulting interval is empty, outputs " { $link f } "." } ;
HELP: assume>=
-{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } }
-{ $description "Outputs the interval consisting of points from " { $snippet "i1" } " which are greater than or equal to all points in " { $snippet "i2" } ". If the resulting interval is empty, outputs " { $link f } "." } ;
+{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
+{ $description "Outputs the interval consisting of points from " { $snippet "i1" } " which are greater than or equal to all points in " { $snippet "i2" } "." } ;
HELP: integral-closure
{ $values { "i1" "an " { $link interval } " with integer end-points" } { "i2" "a closed " { $link interval } " with integer end-points" } }
diff --git a/basis/threads/threads-docs.factor b/basis/threads/threads-docs.factor
index 3c4715d3e3..f6f102c4b4 100644
--- a/basis/threads/threads-docs.factor
+++ b/basis/threads/threads-docs.factor
@@ -1,5 +1,5 @@
USING: help.markup help.syntax kernel kernel.private io
-threads.private continuations dlists init quotations strings
+threads.private continuations init quotations strings
assocs heaps boxes namespaces deques ;
IN: threads
@@ -82,7 +82,7 @@ $nl
{ $notes "In most cases, user code should call " { $link spawn } " instead, however for control over the error handler quotation, threads can be created with " { $link <thread> } " then passed to " { $link (spawn) } "." } ;
HELP: run-queue
-{ $values { "queue" dlist } }
+{ $values { "queue" deque } }
{ $var-description "Global variable holding the queue of runnable threads. Calls to " { $link yield } " switch to the thread which has been in the queue for the longest period of time."
$nl
"By convention, threads are queued with " { $link push-front }
diff --git a/basis/ui/commands/commands-docs.factor b/basis/ui/commands/commands-docs.factor
index 25312ad868..5f1ff6dabd 100644
--- a/basis/ui/commands/commands-docs.factor
+++ b/basis/ui/commands/commands-docs.factor
@@ -71,7 +71,7 @@ HELP: command-word
{ $description "Outputs the word that will be executed by " { $link invoke-command } ". This is only used for documentation purposes." } ;
HELP: command-map
-{ $values { "group" string } { "class" "a class word" } { "command-map" "a " { $link command-map } " or " { $link f } } }
+{ $values { "group" string } { "class" "a class word" } { "command-map" { $maybe command-map } } }
{ $description "Outputs a named command map defined on a class." }
{ $class-description "A command map stores a group of related commands. The " { $snippet "commands" } " slot stores an association list mapping gestures to commands, and the " { $snippet "blurb" } " slot stores an optional one-line description string of this command map."
$nl
@@ -82,7 +82,7 @@ HELP: commands
{ $description "Outputs a hashtable mapping command map names to " { $link command-map } " instances." } ;
HELP: define-command-map
-{ $values { "class" "a class word" } { "group" string } { "blurb" "a " { $link string } " or " { $link f } } { "pairs" "a sequence of gesture/word pairs" } }
+{ $values { "class" "a class word" } { "group" string } { "blurb" { $maybe string } } { "pairs" "a sequence of gesture/word pairs" } }
{ $description
"Defines a command map on the specified gadget class. The " { $snippet "specs" } " parameter is a sequence of pairs " { $snippet "{ gesture word }" } ". The words must be valid commands; see " { $link define-command } "."
}
diff --git a/basis/ui/gadgets/gadgets-docs.factor b/basis/ui/gadgets/gadgets-docs.factor
index 394841c599..5ab20364ee 100644
--- a/basis/ui/gadgets/gadgets-docs.factor
+++ b/basis/ui/gadgets/gadgets-docs.factor
@@ -34,7 +34,7 @@ HELP: children-on
{ $notes "This does not have to be an accurate intersection test, and simply returning " { $snippet "children" } " is a valid implementation. However, an accurate intersection test reduces the amount of work done when drawing this gadget if it is partially clipped and not all children are visible." } ;
HELP: pick-up
-{ $values { "point" "a pair of integers" } { "gadget" gadget } { "child/f" "a " { $link gadget } " or " { $link f } } }
+{ $values { "point" "a pair of integers" } { "gadget" gadget } { "child/f" { $maybe gadget } } }
{ $description "Outputs the child at a point in the gadget's co-ordinate system. This word recursively descends the gadget hierarchy, and so outputs the deepest child." } ;
HELP: max-dim
@@ -52,7 +52,7 @@ HELP: gadget-selection?
{ $contract "Outputs if the gadget has an active text selection; if so, the selected text can be obtained with a call to " { $link gadget-selection } "." } ;
HELP: gadget-selection
-{ $values { "gadget" gadget } { "string/f" "a " { $link string } " or " { $link f } } }
+{ $values { "gadget" gadget } { "string/f" { $maybe string } } }
{ $contract "Outputs the gadget's text selection, or " { $link f } " if nothing is selected." } ;
HELP: relayout
diff --git a/basis/ui/gadgets/scrollers/scrollers-docs.factor b/basis/ui/gadgets/scrollers/scrollers-docs.factor
index 3554c735a7..b248527c37 100644
--- a/basis/ui/gadgets/scrollers/scrollers-docs.factor
+++ b/basis/ui/gadgets/scrollers/scrollers-docs.factor
@@ -8,7 +8,7 @@ $nl
"Scroller gadgets are created by calling " { $link <scroller> } "." } ;
HELP: find-scroller
-{ $values { "gadget" gadget } { "scroller/f" "a " { $link scroller } " or " { $link f } } }
+{ $values { "gadget" gadget } { "scroller/f" { $maybe scroller } } }
{ $description "Finds the first parent of " { $snippet "gadget" } " which is a " { $link scroller } ". Outputs " { $link f } " if the gadget is not contained in a " { $link scroller } "." } ;
HELP: scroller-value
diff --git a/basis/ui/gadgets/sliders/sliders-docs.factor b/basis/ui/gadgets/sliders/sliders-docs.factor
index 63284f135d..c130c724d0 100644
--- a/basis/ui/gadgets/sliders/sliders-docs.factor
+++ b/basis/ui/gadgets/sliders/sliders-docs.factor
@@ -5,7 +5,7 @@ HELP: elevator
{ $class-description "An elevator is the part of a " { $link slider } " between the up/down arrow buttons, where a " { $link thumb } " may be moved up and down." } ;
HELP: find-elevator
-{ $values { "gadget" gadget } { "elevator/f" "an " { $link elevator } " or " { $link f } } }
+{ $values { "gadget" gadget } { "elevator/f" { $maybe elevator } } }
{ $description "Finds the first parent of " { $snippet "gadget" } " which is an " { $link elevator } ". Outputs " { $link f } " if the gadget is not contained in an " { $link elevator } "." } ;
HELP: slider
@@ -14,7 +14,7 @@ $nl
"Sliders are created by calling " { $link <x-slider> } " or " { $link <y-slider> } "." } ;
HELP: find-slider
-{ $values { "gadget" gadget } { "slider/f" "a " { $link slider } " or " { $link f } } }
+{ $values { "gadget" gadget } { "slider/f" { $maybe slider } } }
{ $description "Finds the first parent of " { $snippet "gadget" } " which is a " { $link slider } ". Outputs " { $link f } " if the gadget is not contained in a " { $link slider } "." } ;
HELP: thumb
diff --git a/basis/ui/gadgets/worlds/worlds-docs.factor b/basis/ui/gadgets/worlds/worlds-docs.factor
index 122d14eed7..9dd152885e 100644
--- a/basis/ui/gadgets/worlds/worlds-docs.factor
+++ b/basis/ui/gadgets/worlds/worlds-docs.factor
@@ -46,7 +46,7 @@ HELP: <world>
{ $description "Creates a new " { $link world } " delegating to the given gadget." } ;
HELP: find-world
-{ $values { "gadget" gadget } { "world/f" "a " { $link world } " or " { $link f } } }
+{ $values { "gadget" gadget } { "world/f" { $maybe world } } }
{ $description "Finds the " { $link world } " containing the gadget, or outputs " { $link f } " if the gadget is not grafted." } ;
HELP: draw-world
diff --git a/basis/ui/gestures/gestures-docs.factor b/basis/ui/gestures/gestures-docs.factor
index 0575ff17f0..3471bd2cdb 100644
--- a/basis/ui/gestures/gestures-docs.factor
+++ b/basis/ui/gestures/gestures-docs.factor
@@ -189,7 +189,7 @@ HELP: under-hand
{ $description "Outputs a sequence where the first element is the " { $link hand-world } " and the last is the " { $link hand-gadget } ", with all parents in between." } ;
HELP: gesture>string
-{ $values { "gesture" "a gesture" } { "string/f" "a " { $link string } " or " { $link f } } }
+{ $values { "gesture" "a gesture" } { "string/f" { $maybe string } } }
{ $contract "Creates a human-readable string from a gesture object, returning " { $link f } " if the gesture does not have a human-readable form." }
{ $examples
{ $example "USING: io ui.gestures ;" "T{ key-down f { C+ } \"x\" } gesture>string print" "C+x" }
diff --git a/basis/ui/operations/operations-docs.factor b/basis/ui/operations/operations-docs.factor
index ebdf3eee1f..4ab17228b5 100644
--- a/basis/ui/operations/operations-docs.factor
+++ b/basis/ui/operations/operations-docs.factor
@@ -41,11 +41,11 @@ HELP: object-operations
{ $description "Outputs a sequence of operations applicable to the given object, by testing each defined operation's " { $snippet "predicate" } " quotation in turn." } ;
HELP: primary-operation
-{ $values { "obj" object } { "operation" "an " { $link operation } " or " { $link f } } }
+{ $values { "obj" object } { "operation" { $maybe operation } } }
{ $description "Outputs the operation which should be invoked when a presentation of " { $snippet "obj" } " is clicked." } ;
HELP: secondary-operation
-{ $values { "obj" object } { "operation" "an " { $link operation } " or " { $link f } } }
+{ $values { "obj" object } { "operation" { $maybe operation } } }
{ $description "Outputs the operation which should be invoked when a " { $snippet "RET" } " is pressed while a presentation of " { $snippet "obj" } " is selected in a list." } ;
HELP: define-operation
@@ -61,7 +61,7 @@ HELP: define-operation
} ;
HELP: define-operation-map
-{ $values { "class" "a class word" } { "group" string } { "blurb" "a " { $link string } " or " { $link f } } { "object" object } { "hook" "a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } } { "translator" "a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } } }
+{ $values { "class" "a class word" } { "group" string } { "blurb" { $maybe string } } { "object" object } { "hook" "a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } } { "translator" "a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } } }
{ $description "Defines a command map named " { $snippet "group" } " on " { $snippet "class" } " consisting of operations applicable to " { $snippet "object" } ". The hook quotation is applied to the target gadget; the translator quotation is applied to the result of the hook. Finally the result of the translator is passed to the operation. A distinction is drawn between the hook and the translator because for listener operations, the hook runs in the event loop and the translator runs in the listener. This avoids polluting the listener output with large prettyprinted gadgets and long quotations." } ;
HELP: $operations
diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor
index d8c816d717..9dd3a712c0 100644
--- a/basis/ui/ui-docs.factor
+++ b/basis/ui/ui-docs.factor
@@ -23,7 +23,7 @@ HELP: fullscreen?
{ fullscreen? set-fullscreen? } related-words
HELP: find-window
-{ $values { "quot" "a quotation with stack effect " { $snippet "( world -- ? )" } } { "world" "a " { $link world } " or " { $link f } } }
+{ $values { "quot" "a quotation with stack effect " { $snippet "( world -- ? )" } } { "world" { $maybe world } } }
{ $description "Finds a native window such that the gadget passed to " { $link open-window } " satisfies the quotation, outputting " { $link f } " if no such gadget could be found. The front-most native window is checked first." } ;
HELP: register-window
diff --git a/basis/urls/urls-docs.factor b/basis/urls/urls-docs.factor
index b423e6b751..ce8a7be88c 100644
--- a/basis/urls/urls-docs.factor
+++ b/basis/urls/urls-docs.factor
@@ -77,7 +77,7 @@ HELP: ensure-port
} ;
HELP: parse-host
-{ $values { "string" string } { "host" string } { "port" "an " { $link integer } " or " { $link f } } }
+{ $values { "string" string } { "host" string } { "port" { $maybe integer } } }
{ $description "Splits a string of the form " { $snippet "host:port" } " into a host and a port number. If the port number is not specified, outputs " { $link f } "." }
{ $notes "This word is used by " { $link >url } ". It can also be used directly to parse " { $snippet "host:port" } " strings which are not full URLs." }
{ $examples
@@ -89,13 +89,13 @@ HELP: parse-host
} ;
HELP: protocol-port
-{ $values { "protocol" "a protocol string" } { "port" "an " { $link integer } " or " { $link f } } }
+{ $values { "protocol" "a protocol string" } { "port" { $maybe integer } } }
{ $description "Outputs the port number associated with a protocol, or " { $link f } " if the protocol is unknown." } ;
HELP: query-param
{ $values
{ "url" url } { "key" string }
- { "value" "a " { $link string } " or " { $link f } } }
+ { "value" { $maybe string } } }
{ $description "Outputs the URL-decoded value of a URL query parameter." }
{ $examples
{ $example
diff --git a/core/effects/effects-docs.factor b/core/effects/effects-docs.factor
index f9c18e410d..b209dcf259 100644
--- a/core/effects/effects-docs.factor
+++ b/core/effects/effects-docs.factor
@@ -68,5 +68,5 @@ HELP: effect>string
} ;
HELP: stack-effect
-{ $values { "word" word } { "effect/f" "an " { $link effect } " or " { $link f } } }
+{ $values { "word" word } { "effect/f" { $maybe effect } } }
{ $description "Outputs the stack effect of a word; either a stack effect declared with " { $link POSTPONE: ( } ", or an inferred stack effect (see " { $link "inference" } "." } ;
diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor
index 396b3e8f9a..182cfbf419 100644
--- a/core/generic/generic-docs.factor
+++ b/core/generic/generic-docs.factor
@@ -127,7 +127,7 @@ HELP: method-body
{ $class-description "The class of method bodies, which are words with special word properties set." } ;
HELP: method
-{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } }
+{ $values { "class" class } { "generic" generic } { "method/f" { $maybe method-body } } }
{ $description "Looks up a method definition." } ;
{ method create-method POSTPONE: M: } related-words
diff --git a/core/lexer/lexer-docs.factor b/core/lexer/lexer-docs.factor
index 67948cc8f9..ead3c15a37 100644
--- a/core/lexer/lexer-docs.factor
+++ b/core/lexer/lexer-docs.factor
@@ -54,11 +54,11 @@ HELP: still-parsing-line?
{ $description "Outputs " { $link f } " if the end of the current line has been reached, " { $link t } " otherwise." } ;
HELP: parse-token
-{ $values { "lexer" lexer } { "str/f" "a " { $link string } " or " { $link f } } }
+{ $values { "lexer" lexer } { "str/f" { $maybe string } } }
{ $description "Reads the next token from the lexer. Tokens are delimited by whitespace, with the exception that " { $snippet "\"" } " is treated like a single token even when not followed by whitespace." } ;
HELP: scan
-{ $values { "str/f" "a " { $link string } " or " { $link f } } }
+{ $values { "str/f" { $maybe string } } }
{ $description "Reads the next token from the lexer. See " { $link parse-token } " for details." }
$parsing-note ;
@@ -73,7 +73,7 @@ HELP: parse-tokens
$parsing-note ;
HELP: unexpected
-{ $values { "want" "a " { $link word } " or " { $link f } } { "got" word } }
+{ $values { "want" { $maybe word } } { "got" word } }
{ $description "Throws an " { $link unexpected } " error." }
{ $error-description "Thrown by the parser if an unmatched closing delimiter is encountered." }
{ $examples
diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor
index d2d7dc1102..c9ce334388 100644
--- a/core/slots/slots-docs.factor
+++ b/core/slots/slots-docs.factor
@@ -166,5 +166,5 @@ HELP: set-slot ( value obj n -- )
{ $warning "This word is in the " { $vocab-link "slots.private" } " vocabulary because it does not perform type or bounds checks, and slot numbers are implementation detail." } ;
HELP: slot-named
-{ $values { "name" string } { "specs" "a sequence of " { $link slot-spec } " instances" } { "spec/f" "a " { $link slot-spec } " or " { $link f } } }
+{ $values { "name" string } { "specs" "a sequence of " { $link slot-spec } " instances" } { "spec/f" { $maybe slot-spec } } }
{ $description "Outputs the " { $link slot-spec } " with the given name." } ;
From 4f77607c1387fdc742dac32cc87c7ca4ba81bff7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 06:57:53 -0600
Subject: [PATCH 111/157] Fix tests, and clear-deque on dlists
---
basis/dlists/dlists-tests.factor | 10 +++++-----
basis/dlists/dlists.factor | 1 -
basis/ui/gadgets/gadgets-tests.factor | 2 +-
3 files changed, 6 insertions(+), 7 deletions(-)
diff --git a/basis/dlists/dlists-tests.factor b/basis/dlists/dlists-tests.factor
index 613fe56542..6df3e306dd 100644
--- a/basis/dlists/dlists-tests.factor
+++ b/basis/dlists/dlists-tests.factor
@@ -5,7 +5,7 @@ IN: dlists.tests
[ t ] [ <dlist> deque-empty? ] unit-test
-[ T{ dlist f T{ dlist-node f 1 f f } T{ dlist-node f 1 f f } 1 } ]
+[ T{ dlist f T{ dlist-node f 1 f f } T{ dlist-node f 1 f f } } ]
[ <dlist> 1 over push-front ] unit-test
! Make sure empty lists are empty
@@ -17,10 +17,10 @@ IN: dlists.tests
[ 1 ] [ <dlist> 1 over push-front pop-back ] unit-test
[ 1 ] [ <dlist> 1 over push-back pop-front ] unit-test
[ 1 ] [ <dlist> 1 over push-back pop-back ] unit-test
-[ T{ dlist f f f 0 } ] [ <dlist> 1 over push-front dup pop-front* ] unit-test
-[ T{ dlist f f f 0 } ] [ <dlist> 1 over push-front dup pop-back* ] unit-test
-[ T{ dlist f f f 0 } ] [ <dlist> 1 over push-back dup pop-front* ] unit-test
-[ T{ dlist f f f 0 } ] [ <dlist> 1 over push-back dup pop-back* ] unit-test
+[ T{ dlist f f f } ] [ <dlist> 1 over push-front dup pop-front* ] unit-test
+[ T{ dlist f f f } ] [ <dlist> 1 over push-front dup pop-back* ] unit-test
+[ T{ dlist f f f } ] [ <dlist> 1 over push-back dup pop-front* ] unit-test
+[ T{ dlist f f f } ] [ <dlist> 1 over push-back dup pop-back* ] unit-test
! Test the prev,next links for two nodes
[ f ] [
diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor
index bd0e0f28cf..eb12d337b3 100644
--- a/basis/dlists/dlists.factor
+++ b/basis/dlists/dlists.factor
@@ -148,7 +148,6 @@ M: dlist delete-node ( dlist-node dlist -- )
M: dlist clear-deque ( dlist -- )
f >>front
f >>back
- 0 >>length
drop ;
: dlist-each ( dlist quot -- )
diff --git a/basis/ui/gadgets/gadgets-tests.factor b/basis/ui/gadgets/gadgets-tests.factor
index 877d4ad145..01d695c281 100644
--- a/basis/ui/gadgets/gadgets-tests.factor
+++ b/basis/ui/gadgets/gadgets-tests.factor
@@ -138,7 +138,7 @@ M: mock-gadget ungraft*
[ V{ { f t } } ] [ status-flags ] unit-test
dup [ [ ] [ notify-queued ] unit-test ] when
[ ] [ "g" get clear-gadget ] unit-test
- [ [ 1 ] [ graft-queue length>> ] unit-test ] unless
+ [ [ t ] [ graft-queue [ front>> ] [ back>> ] bi eq? ] unit-test ] unless
[ [ ] [ notify-queued ] unit-test ] when
[ ] [ add-some-children ] unit-test
[ { f t } ] [ "1" get graft-state>> ] unit-test
From 134dacdb6b155b451971c8435c49db0d543487fe Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 07:04:51 -0600
Subject: [PATCH 112/157] Fix help lint
---
basis/dlists/dlists-docs.factor | 1 +
basis/dlists/dlists.factor | 2 +-
basis/unrolled-lists/unrolled-lists.factor | 2 +-
3 files changed, 3 insertions(+), 2 deletions(-)
diff --git a/basis/dlists/dlists-docs.factor b/basis/dlists/dlists-docs.factor
index 5a19936a97..ef6087f852 100644
--- a/basis/dlists/dlists-docs.factor
+++ b/basis/dlists/dlists-docs.factor
@@ -25,6 +25,7 @@ $nl
ABOUT: "dlists"
HELP: <dlist>
+{ $values { "list" dlist } }
{ $description "Creates a new double-linked list." } ;
HELP: <hashed-dlist>
diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor
index eb12d337b3..549dbf947d 100644
--- a/basis/dlists/dlists.factor
+++ b/basis/dlists/dlists.factor
@@ -23,7 +23,7 @@ TUPLE: dlist
{ front ?dlist-node }
{ back ?dlist-node } ;
-: <dlist> ( -- obj )
+: <dlist> ( -- list )
dlist new ; inline
: <hashed-dlist> ( -- search-deque )
diff --git a/basis/unrolled-lists/unrolled-lists.factor b/basis/unrolled-lists/unrolled-lists.factor
index 27f7175315..d434632abd 100644
--- a/basis/unrolled-lists/unrolled-lists.factor
+++ b/basis/unrolled-lists/unrolled-lists.factor
@@ -23,7 +23,7 @@ TUPLE: unrolled-list
unrolled-list new
unroll-factor >>back-pos ; inline
-: <hashed-unrolled-list> ( -- list )
+: <hashed-unrolled-list> ( -- search-deque )
20 <hashtable> <unrolled-list> <search-deque> ;
ERROR: empty-unrolled-list list ;
From 7a26f30d852774d842dcc724b8e2a7e13be0b97d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 07:19:05 -0600
Subject: [PATCH 113/157] Documentation for furnace.auth.providers
---
.../auth/providers/assoc/assoc-docs.factor | 14 ++++++
.../furnace/auth/providers/db/db-docs.factor | 13 ++++++
.../auth/providers/null/null-docs.factor | 10 +++++
.../auth/providers/providers-docs.factor | 45 +++++++++++++++++++
4 files changed, 82 insertions(+)
create mode 100644 basis/furnace/auth/providers/assoc/assoc-docs.factor
create mode 100644 basis/furnace/auth/providers/db/db-docs.factor
create mode 100644 basis/furnace/auth/providers/null/null-docs.factor
create mode 100644 basis/furnace/auth/providers/providers-docs.factor
diff --git a/basis/furnace/auth/providers/assoc/assoc-docs.factor b/basis/furnace/auth/providers/assoc/assoc-docs.factor
new file mode 100644
index 0000000000..61c2ac4eed
--- /dev/null
+++ b/basis/furnace/auth/providers/assoc/assoc-docs.factor
@@ -0,0 +1,14 @@
+USING: help.markup help.syntax io.streams.string ;
+IN: furnace.auth.providers.assoc
+
+HELP: <users-in-memory>
+{ $values { "provider" users-in-memory } }
+{ $description "Creates a new authentication provider which stores the usernames and passwords in an associative mapping." } ;
+
+ARTICLE: "furnace.auth.providers.assoc" "In-memory authentication provider"
+"The " { $vocab-link "furnace.auth.providers.assoc" } " vocabulary implements an authentication provider which looks up usernames and passwords in an associative mapping."
+{ $subsection users-in-memory }
+{ $subsection <users-in-memory> }
+"The " { $slot "assoc" } " slot of the " { $link users-in-memory } " tuple maps usernames to checksums of passwords." ;
+
+ABOUT: "furnace.auth.providers.assoc"
diff --git a/basis/furnace/auth/providers/db/db-docs.factor b/basis/furnace/auth/providers/db/db-docs.factor
new file mode 100644
index 0000000000..219edf9490
--- /dev/null
+++ b/basis/furnace/auth/providers/db/db-docs.factor
@@ -0,0 +1,13 @@
+USING: help.markup help.syntax ;
+IN: furnace.auth.providers.db
+
+HELP: users-in-db
+{ $class-description "Singleton class implementing the database authentication provider." } ;
+
+ARTICLE: "furnace.auth.providers.db" "Database authentication provider"
+"The " { $vocab-link "furnace.auth.providers.db" } " vocabulary implements an authentication provider which looks up authentication requests in the " { $snippet "USERS" } " table of the current database. The database schema is Factor-specific, and the table should be initialized by calling"
+{ $code "users create-table" }
+"The authentication provider class:"
+{ $subsection users-in-db } ;
+
+ABOUT: "furnace.auth.providers.db"
diff --git a/basis/furnace/auth/providers/null/null-docs.factor b/basis/furnace/auth/providers/null/null-docs.factor
new file mode 100644
index 0000000000..100b16c7d3
--- /dev/null
+++ b/basis/furnace/auth/providers/null/null-docs.factor
@@ -0,0 +1,10 @@
+USING: help.markup help.syntax ;
+IN: furnace.auth.providers.null
+
+HELP: no-users
+{ $class-description "Singleton class implementing the dummy authentication provider." } ;
+
+ARTICLE: "furnace.auth.providers.null" "Dummy authentication provider"
+"The " { $vocab-link "furnace.auth.providers.null" } " vocabulary implements an authentication provider which refuses all authentication requests. It is only useful for testing purposes." ;
+
+ABOUT: "furnace.auth.providers.null"
diff --git a/basis/furnace/auth/providers/providers-docs.factor b/basis/furnace/auth/providers/providers-docs.factor
new file mode 100644
index 0000000000..5d15bf4f65
--- /dev/null
+++ b/basis/furnace/auth/providers/providers-docs.factor
@@ -0,0 +1,45 @@
+USING: help.markup help.syntax strings ;
+IN: furnace.auth.providers
+
+HELP: user
+{ $class-description "The class of users. Instances have the following slots:"
+{ $table
+ { { $slot "username" } { "The username, used to identify the user for login purposes" } }
+ { { $slot "realname" } { "The user's real name, optional" } }
+ { { $slot "password" } { "The user's password, encoded with a checksum" } }
+ { { $slot "salt" } { "A random salt prepended to the password to ensure that two users with the same plain-text password still have different checksum output" } }
+ { { $slot "email" } { "The user's e-mail address, optional" } }
+ { { $slot "ticket" } { "Used for password recovery" } }
+ { { $slot "capabilities" } { "A sequence of capabilities; see " { $link "furnace.auth.capabilities" } } }
+ { { $slot "profile" } { "A hashtable with webapp-specific configuration" } }
+ { { $slot "deleted" } { "A boolean indicating whether the user is active or not. This allows a user account to be deactivated without removing the user from the database" } }
+ { { $slot "changed?" } { "A boolean indicating whether the user has changed since being retrieved from the database" } }
+} } ;
+
+HELP: add-user
+{ $values { "provider" "an authentication provider" } { "user" user } }
+{ $description "A utility word which calls " { $link new-user } " and throws an error if the user already exists." } ;
+
+HELP: get-user
+{ $values { "username" string } { "provider" "an authentication provider" } { "user/f" { $maybe user } } }
+{ $contract "Looks up a username in the authentication provider." } ;
+
+HELP: new-user
+{ $values { "user" user } { "provider" "an authentication provider" } { "user/f" { $maybe user } } }
+{ $contract "Adds a new user to the authentication provider. Outputs " { $link f } " if a user with this username already exists." } ;
+
+HELP: update-user
+{ $values { "user" user } { "provider" "an authentication provider" } }
+{ $contract "Stores a user back to an authentication provider after being changed. This is a no-op with in-memory providers; providers which use an external store will save the user in this word. " } ;
+
+ARTICLE: "furnace.auth.providers.protocol" "Authentication provider protocol"
+"The " { $vocab-link "furnace.auth.providers" } " vocabulary implements a protocol for persistence and authentication of users."
+$nl
+"The class of users:"
+{ $subsection user }
+"Generic protocol:"
+{ $subsection get-user }
+{ $subsection new-user }
+{ $subsection update-user } ;
+
+ABOUT: "furnace.auth.providers.protocol"
From 1412778ff8ba786ff55d0b3474bf5d3539f3e6bb Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 07:19:20 -0600
Subject: [PATCH 114/157] Documentation for furnace.auth.basic
---
basis/furnace/auth/basic/basic-docs.factor | 12 ++++++++++++
1 file changed, 12 insertions(+)
create mode 100644 basis/furnace/auth/basic/basic-docs.factor
diff --git a/basis/furnace/auth/basic/basic-docs.factor b/basis/furnace/auth/basic/basic-docs.factor
new file mode 100644
index 0000000000..25929d4346
--- /dev/null
+++ b/basis/furnace/auth/basic/basic-docs.factor
@@ -0,0 +1,12 @@
+USING: help.markup help.syntax ;
+IN: furnace.auth.basic
+
+HELP: <basic-auth-realm>
+{ $values { "responder" "a responder" } { "name" "an authentication realm name" } { "realm" basic-auth-realm } }
+{ $description "Wraps a responder in a basic authentication realm." } ;
+
+ARTICLE: "furnace.auth.basic" "Basic authentication"
+"The " { $vocab-link "furnace.auth.basic" } " vocabulary implements HTTP basic authentication."
+{ $subsection <basic-auth-realm> } ;
+
+ABOUT: "furnace.auth.basic"
From c0a38be8cce045dccf1ef120a277e82de047435c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 07:27:31 -0600
Subject: [PATCH 115/157] Documentation for furnace.auth.login
---
basis/furnace/auth/basic/basic-docs.factor | 6 +++++-
basis/furnace/auth/login/login-docs.factor | 25 ++++++++++++++++++++++
basis/furnace/auth/login/login.factor | 6 +++++-
3 files changed, 35 insertions(+), 2 deletions(-)
create mode 100644 basis/furnace/auth/login/login-docs.factor
diff --git a/basis/furnace/auth/basic/basic-docs.factor b/basis/furnace/auth/basic/basic-docs.factor
index 25929d4346..c0d3184c78 100644
--- a/basis/furnace/auth/basic/basic-docs.factor
+++ b/basis/furnace/auth/basic/basic-docs.factor
@@ -3,10 +3,14 @@ IN: furnace.auth.basic
HELP: <basic-auth-realm>
{ $values { "responder" "a responder" } { "name" "an authentication realm name" } { "realm" basic-auth-realm } }
-{ $description "Wraps a responder in a basic authentication realm." } ;
+{ $description "Wraps a responder in a basic authentication realm. The realm must be configured before use; see " { $link "furnace.auth.realm-config" } "." } ;
+
+HELP: basic-auth-realm
+{ $class-description "The basic authentication realm class. Slots are described in " { $link "furnace.auth.realm-config" } "." } ;
ARTICLE: "furnace.auth.basic" "Basic authentication"
"The " { $vocab-link "furnace.auth.basic" } " vocabulary implements HTTP basic authentication."
+{ $subsection basic-auth-realm }
{ $subsection <basic-auth-realm> } ;
ABOUT: "furnace.auth.basic"
diff --git a/basis/furnace/auth/login/login-docs.factor b/basis/furnace/auth/login/login-docs.factor
new file mode 100644
index 0000000000..e461388e73
--- /dev/null
+++ b/basis/furnace/auth/login/login-docs.factor
@@ -0,0 +1,25 @@
+! Copyright (C) 2008 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel strings ;
+IN: furnace.auth.login
+
+HELP: <login-realm>
+{ $values
+ { "responder" "a responder" } { "name" string }
+ { "realm" "a new responder" }
+}
+{ $description "Wraps a responder in a new login realm with the given name. The realm must be configured before use; see " { $link "furnace.auth.realm-config" } "." } ;
+
+HELP: login-realm
+{ $class-description "The login realm class. Slots are described in " { $link "furnace.auth.realm-config" } "." } ;
+
+ARTICLE: "furnace.auth.login" "Login authentication"
+"The " { $vocab-link "furnace.auth.login" } " vocabulary implements an authentication realm which displays a login page with a username and password field."
+{ $subsection login-realm }
+{ $subsection <login-realm> }
+"The " { $snippet "logout" } " action logs the user out of the realm, and a link to this action can be inserted in Chloe templates using the following XML snippet:"
+{ $code
+ "<t:button t:action=\"$login-realm/logout\">Logout</t:button>"
+} ;
+
+ABOUT: "furnace.auth.login"
diff --git a/basis/furnace/auth/login/login.factor b/basis/furnace/auth/login/login.factor
index 2c98672490..4fc4e7e8be 100644
--- a/basis/furnace/auth/login/login.factor
+++ b/basis/furnace/auth/login/login.factor
@@ -58,9 +58,13 @@ M: login-realm modify-form ( responder -- )
permit-id get [ delete-permit ] when*
URL" $realm" end-aside ;
+<PRIVATE
+
SYMBOL: description
SYMBOL: capabilities
+PRIVATE>
+
: flashed-variables { description capabilities } ;
: login-failed ( -- * )
@@ -107,7 +111,7 @@ M: login-realm login-required* ( description capabilities login -- response )
M: login-realm user-registered ( user realm -- )
drop successful-login ;
-: <login-realm> ( responder name -- auth )
+: <login-realm> ( responder name -- realm )
login-realm new-realm
<login-action> "login" add-responder
<logout-action> "logout" add-responder
From 4a40b03a10f4420dfbf732dbe73e5743fe0933ef Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 07:41:27 -0600
Subject: [PATCH 116/157] Document furnace.auth.features
---
.../deactivate-user-docs.factor | 26 ++++++++++++++
.../edit-profile/edit-profile-docs.factor | 24 +++++++++++++
.../features/edit-profile/edit-profile.factor | 2 +-
.../recover-password-docs.factor | 34 +++++++++++++++++++
.../registration/registration-docs.factor | 24 +++++++++++++
.../features/registration/registration.factor | 2 +-
basis/furnace/auth/login/login-docs.factor | 2 --
7 files changed, 110 insertions(+), 4 deletions(-)
create mode 100644 basis/furnace/auth/features/deactivate-user/deactivate-user-docs.factor
create mode 100644 basis/furnace/auth/features/edit-profile/edit-profile-docs.factor
create mode 100644 basis/furnace/auth/features/recover-password/recover-password-docs.factor
create mode 100644 basis/furnace/auth/features/registration/registration-docs.factor
diff --git a/basis/furnace/auth/features/deactivate-user/deactivate-user-docs.factor b/basis/furnace/auth/features/deactivate-user/deactivate-user-docs.factor
new file mode 100644
index 0000000000..ef4f2e1075
--- /dev/null
+++ b/basis/furnace/auth/features/deactivate-user/deactivate-user-docs.factor
@@ -0,0 +1,26 @@
+USING: help.markup help.syntax kernel ;
+IN: furnace.auth.features.deactivate-user
+
+HELP: allow-deactivation
+{ $values { "realm" "an authentication realm" } }
+{ $description "Adds a " { $snippet "deactivate-user" } " action to an authentication realm." } ;
+
+HELP: allow-deactivation?
+{ $values { "?" "a boolean" } }
+{ $description "Outputs true if the current authentication realm allows user profile deactivation." } ;
+
+ARTICLE: "furnace.auth.features.deactivate-user" "User profile deactivation"
+"The " { $vocab-link "furnace.auth.features.deactivate-user" } " vocabulary implements an authentication feature for user profile deactivation, allowing users to voluntarily deactivate their account."
+$nl
+"To enable this feature, call the following word on an authentication realm:"
+{ $subsection allow-deactivation }
+"To check if deactivation is enabled:"
+{ $subsection allow-deactivation? }
+"This feature adds a " { $snippet "deactivate-user" } " action to the realm, and a link to this action can be inserted in Chloe templates using the following XML snippet:"
+{ $code
+ "<t:if t:code=\"furnace.auth.features.deactivate-user:allow-deactivation?\">"
+ " <t:button t:action=\"$realm/deactivate-user\">Deactivate user</t:button>"
+ "</t:if>"
+} ;
+
+ABOUT: "furnace.auth.features.deactivate-user"
diff --git a/basis/furnace/auth/features/edit-profile/edit-profile-docs.factor b/basis/furnace/auth/features/edit-profile/edit-profile-docs.factor
new file mode 100644
index 0000000000..6f3c9d151b
--- /dev/null
+++ b/basis/furnace/auth/features/edit-profile/edit-profile-docs.factor
@@ -0,0 +1,24 @@
+USING: help.markup help.syntax kernel ;
+IN: furnace.auth.features.edit-profile
+
+HELP: allow-edit-profile
+{ $values { "realm" "an authentication realm" } }
+{ $description "Adds an " { $snippet "edit-profile" } " action to an authentication realm." } ;
+
+HELP: allow-edit-profile?
+{ $values { "?" "a boolean" } }
+{ $description "Outputs true if the current authentication realm allows user profile editing." } ;
+
+ARTICLE: "furnace.auth.features.edit-profile" "User profile editing"
+"The " { $vocab-link "furnace.auth.features.edit-profile" } " vocabulary implements an authentication feature for user profile editing, allowing users to change some details of their account."
+$nl
+"To enable this feature, call the following word on an authentication realm:"
+{ $subsection allow-edit-profile }
+"To check if profile editing is enabled:"
+{ $subsection allow-edit-profile? }
+"This feature adds an " { $snippet "edit-profile" } " action to the realm, and a link to this action can be inserted in Chloe templates using the following XML snippet:"
+{ $code
+ "<t:if t:code=\"furnace.auth.features.edit-profile:allow-edit-profile?\">"
+ " <t:button t:action=\"$realm/edit-profile\">Edit profile</t:button>"
+ "</t:if>"
+} ;
diff --git a/basis/furnace/auth/features/edit-profile/edit-profile.factor b/basis/furnace/auth/features/edit-profile/edit-profile.factor
index 243ea7bfff..cefb472b22 100644
--- a/basis/furnace/auth/features/edit-profile/edit-profile.factor
+++ b/basis/furnace/auth/features/edit-profile/edit-profile.factor
@@ -58,7 +58,7 @@ IN: furnace.auth.features.edit-profile
<protected>
"edit your profile" >>description ;
-: allow-edit-profile ( login -- login )
+: allow-edit-profile ( realm -- realm )
<edit-profile-action> <auth-boilerplate> "edit-profile" add-responder ;
: allow-edit-profile? ( -- ? )
diff --git a/basis/furnace/auth/features/recover-password/recover-password-docs.factor b/basis/furnace/auth/features/recover-password/recover-password-docs.factor
new file mode 100644
index 0000000000..1dc7e99eff
--- /dev/null
+++ b/basis/furnace/auth/features/recover-password/recover-password-docs.factor
@@ -0,0 +1,34 @@
+USING: help.markup help.syntax kernel strings urls ;
+IN: furnace.auth.features.recover-password
+
+HELP: allow-password-recovery
+{ $values { "realm" "an authentication realm" } }
+{ $description "Adds a " { $snippet "recover-password" } " action to an authentication realm." } ;
+
+HELP: allow-password-recovery?
+{ $values { "?" "a boolean" } }
+{ $description "Outputs true if the current authentication realm allows user password recovery." } ;
+
+HELP: lost-password-from
+{ $var-description "A variable with the source e-mail address of password recovery e-mails." } ;
+
+ARTICLE: "furnace.auth.features.recover-password" "User password recovery"
+"The " { $vocab-link "furnace.auth.features.recover-password" }
+" vocabulary implements an authentication feature for user password recovery, allowing users to get a new password e-mailed to them in the event they forget their current one."
+$nl
+"To enable this feature, first call the following word on an authentication realm,"
+{ $subsection allow-password-recovery }
+"Then set a global configuration variable:"
+{ $subsection lost-password-from }
+"In addition, the " { $link "smtp" } " may need to be configured as well."
+$nl
+"To check if password recovery is enabled:"
+{ $subsection allow-password-recovery? }
+"This feature adds a " { $snippet "recover-password" } " action to the realm, and a link to this action can be inserted in Chloe templates using the following XML snippet:"
+{ $code
+ "<t:if t:code=\"furnace.auth.features.recover-password:allow-password-recovery?\">"
+ " <t:button t:action=\"$realm/recover-password\">Recover password</t:button>"
+ "</t:if>"
+} ;
+
+ABOUT: "furnace.auth.features.recover-password"
diff --git a/basis/furnace/auth/features/registration/registration-docs.factor b/basis/furnace/auth/features/registration/registration-docs.factor
new file mode 100644
index 0000000000..1f12570173
--- /dev/null
+++ b/basis/furnace/auth/features/registration/registration-docs.factor
@@ -0,0 +1,24 @@
+USING: help.markup help.syntax kernel ;
+IN: furnace.auth.features.registration
+
+HELP: allow-registration
+{ $values { "realm" "an authentication realm" } }
+{ $description "Adds a " { $snippet "registration" } " action to an authentication realm." } ;
+
+HELP: allow-registration?
+{ $values { "?" "a boolean" } }
+{ $description "Outputs true if the current authentication realm allows user registration." } ;
+
+ARTICLE: "furnace.auth.features.registration" "User registration"
+"The " { $vocab-link "furnace.auth.features.registration" } " vocabulary implements an authentication feature for user registration, allowing new users to create accounts."
+$nl
+"To enable this feature, call the following word on an authentication realm:"
+{ $subsection allow-registration }
+"To check if user registration is enabled:"
+{ $subsection allow-registration? }
+"This feature adds a " { $snippet "register" } " action to the realm. A link to this action is inserted on the login page if the " { $vocab-link "furnace.auth.login" } " authentication realm is used. Links to this action can be inserted from other pages using the following Chloe XML snippet:"
+{ $code
+ "<t:if t:code=\"furnace.auth.features.registration:allow-registration?\">"
+ " <t:button t:action=\"$realm/register\">Register</t:button>"
+ "</t:if>"
+} ;
diff --git a/basis/furnace/auth/features/registration/registration.factor b/basis/furnace/auth/features/registration/registration.factor
index ef8923c98b..0484c11727 100644
--- a/basis/furnace/auth/features/registration/registration.factor
+++ b/basis/furnace/auth/features/registration/registration.factor
@@ -38,7 +38,7 @@ IN: furnace.auth.features.registration
<auth-boilerplate>
<secure-realm-only> ;
-: allow-registration ( login -- login )
+: allow-registration ( realm -- realm )
<register-action> "register" add-responder ;
: allow-registration? ( -- ? )
diff --git a/basis/furnace/auth/login/login-docs.factor b/basis/furnace/auth/login/login-docs.factor
index e461388e73..08b7d933e6 100644
--- a/basis/furnace/auth/login/login-docs.factor
+++ b/basis/furnace/auth/login/login-docs.factor
@@ -1,5 +1,3 @@
-! Copyright (C) 2008 Your name.
-! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel strings ;
IN: furnace.auth.login
From 2d561ade79daaa7f6d9fd773175492919b6ddb9c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 08:39:08 -0600
Subject: [PATCH 117/157] Document furnace.auth
---
basis/furnace/auth/auth-docs.factor | 193 ++++++++++++++++++
.../recover-password/recover-password.factor | 2 +-
basis/furnace/furnace-docs.factor | 4 +-
basis/furnace/furnace.factor | 1 +
basis/furnace/summary.txt | 1 +
5 files changed, 199 insertions(+), 2 deletions(-)
create mode 100644 basis/furnace/auth/auth-docs.factor
create mode 100644 basis/furnace/summary.txt
diff --git a/basis/furnace/auth/auth-docs.factor b/basis/furnace/auth/auth-docs.factor
new file mode 100644
index 0000000000..210254aa15
--- /dev/null
+++ b/basis/furnace/auth/auth-docs.factor
@@ -0,0 +1,193 @@
+USING: assocs classes help.markup help.syntax kernel
+quotations strings words furnace.auth.providers.db
+checksums.sha2 furnace.auth.providers math byte-arrays
+http multiline ;
+IN: furnace.auth
+
+HELP: <protected>
+{ $values
+ { "responder" "a responder" }
+ { "protected" "a new responder" }
+}
+{ $description "Wraps a responder in a protected responder. Access to the wrapped responder will be conditional upon the client authenticating with the current authentication realm." } ;
+
+HELP: >>encoded-password
+{ $values { "user" user } { "string" string } }
+{ $description "Sets the user's password by combining it with a random salt and encoding it with the current authentication realm's checksum." } ;
+
+HELP: capabilities
+{ $var-description "Global variable holding all defined capabilities. New capabilities may be defined with " { $link define-capability } "." } ;
+
+HELP: check-login
+{ $values { "password" string } { "username" string } { "user/f" { $maybe user } } }
+{ $description "Checks a username/password pair with the current authentication realm. Outputs a user if authentication succeeded, otherwise outputs " { $link f } "." } ;
+
+HELP: define-capability
+{ $values { "word" symbol } }
+{ $description "Defines a new capability by adding it to the " { $link capabilities } " global variable." } ;
+
+HELP: encode-password
+{ $values
+ { "string" string } { "salt" integer }
+ { "bytes" byte-array }
+}
+{ $description "Encodes a password with the current authentication realm's checksum." } ;
+
+HELP: have-capabilities?
+{ $values
+ { "capabilities" "a sequence of capabilities" }
+ { "?" "a boolean" }
+}
+{ $description "Tests if the currently logged-in user possesses the given capabilities." } ;
+
+HELP: logged-in-user
+{ $var-description "Holds the currently logged-in user." } ;
+
+HELP: login-required
+{ $values
+ { "description" string } { "capabilities" "a sequence of capabilities" }
+}
+{ $description "Redirects the client to a login page." } ;
+
+HELP: login-required*
+{ $values
+ { "description" string } { "capabilities" "a sequence of capabilities" } { "realm" "an authenticaiton realm" }
+ { "response" response }
+}
+{ $contract "Constructs an HTTP response for redirecting the client to a login page." } ;
+
+HELP: protected
+{ $class-description "The class of protected responders. See " { $link "furnace.auth.protected" } " for a description of usage and slots." } ;
+
+HELP: realm
+{ $class-description "The class of authentication realms. See " { $link "furnace.auth.realms" } " for details." } ;
+
+HELP: uchange
+{ $values { "key" symbol } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } }
+{ $description "Applies the quotation to the old value of the user profile variable, and assigns the resulting value back to the variable." } ;
+
+HELP: uget
+{ $values { "key" symbol } { "value" object } }
+{ $description "Outputs the value of a user profile variable." } ;
+
+HELP: uset
+{ $values { "value" object } { "key" symbol } }
+{ $description "Sets the value of a user profile variable." } ;
+
+HELP: username
+{ $values { "string/f" { $maybe string } }
+}
+{ $description "Outputs the currently logged-in username, or " { $link f } " if no user is logged in." } ;
+HELP: users
+{ $values { "provider" "an authentication provider" } }
+{ $description "Outputs the current authentication provider." } ;
+
+ARTICLE: "furnace.auth.capabilities" "Authentication capabilities"
+"Every user in the authentication framework has a set of associated capabilities."
+$nl
+"Defining new capabilities:"
+{ $subsection define-capability }
+"Capabilities are stored in a global variable:"
+{ $subsection capabilities }
+"Protected resources can be restricted to users possessing certain capabilities only by storing a sequence of capabilities in the " { $slot "capabilities" } " slot of a " { $link protected } " instance." ;
+
+ARTICLE: "furnace.auth.protected" "Protected resources"
+"To restrict access to authenticated clients only, wrap a responder in a protected responder."
+{ $subsection protected }
+{ $subsection <protected> }
+"Protected responders have the following two slots which may be set:"
+{ $table
+ { { $slot "description" } "A string identifying the protected resource for user interface purposes" }
+ { { $slot "capabilities" } { "A sequence of capabilities; see " { $link "furnace.auth.capabilities" } } }
+} ;
+
+ARTICLE: "furnace.auth.realm-config" "Authentication realm configuration"
+"Instances of subclasses of " { $link realm } " have the following slots which may be set:"
+{ $table
+ { { $slot "name" } "A string identifying the realm for user interface purposes" }
+ { { $slot "users" } { "An authentication provider (see " { $link "furnace.auth.providers" } ". By default, the " { $link users-in-db } " provider is used." } }
+ { { $slot "checksum" } { "An implementation of the checksum protocol used for verifying passwords (see " { $link "checksums" } "). The " { $link sha-256 } " checksum is used by default." } }
+ { { $slot "users" } { "An authentication provider (see " { $link "furnace.auth.providers" } } }
+ { { $slot "secure" } { "A boolean, that when set to a true value, forces the client to access the authentication realm via HTTPS. An attempt to access the realm via HTTP results in a redirect to the corresponding HTTPS URL. On by default." } }
+} ;
+
+ARTICLE: "furnace.auth.providers" "Authentication providers"
+"The " { $vocab-link "furnace.auth" } " framework looks up users using an authentication provider. Different authentication providers can be swapped in to implement various authentication strategies."
+$nl
+"Each authentication realm has a provider stored in the " { $slot "users" } " slot. The default provider is " { $link users-in-db } "."
+{ $subsection "furnace.auth.providers.protocol" }
+{ $subsection "furnace.auth.providers.null" }
+{ $subsection "furnace.auth.providers.assoc" }
+{ $subsection "furnace.auth.providers.db" } ;
+
+ARTICLE: "furnace.auth.features" "Optional authentication features"
+"Vocabularies having names prefixed by " { $code "furnace.auth.features" } " implement optional features which can be enabled by calling special words. These words define new actions on an authentication realm."
+{ $subsection "furnace.auth.features.deactivate-user" }
+{ $subsection "furnace.auth.features.edit-profile" }
+{ $subsection "furnace.auth.features.recover-password" }
+{ $subsection "furnace.auth.features.registration" } ;
+
+ARTICLE: "furnace.auth.realms" "Authentication realms"
+"The superclass of authentication realms:"
+{ $subsection realm }
+"There are two concrete implementations:"
+{ $subsection "furnace.auth.basic" }
+{ $subsection "furnace.auth.login" }
+"Authentication realms need to be configured after construction."
+{ $subsection "furnace.auth.realm-config" } ;
+
+ARTICLE: "furnace.auth.users" "User profiles"
+"A responder wrapped in an authentication realm may access the currently logged-in user,"
+{ $subsection logged-in-user }
+"as well as the logged-in username:"
+{ $subsection username }
+"Values can also be stored in user profile variables:"
+{ $subsection uget }
+{ $subsection uset }
+{ $subsection uchange }
+"User profile variables have the same restrictions on their values as session variables; see " { $link "furnace.sessions.serialize" } " for a discussion." ;
+
+ARTICLE: "furnace.auth.example" "Furnace authentication example"
+"The " { $vocab-link "webapps.todo" } " vocabulary wraps all of its responders in a protected responder. The " { $slot "description" } " slot is set so that the login page contains the message ``You must log in to view your todo list'':"
+{ $code
+ <" <protected>
+ "view your todo list" >>description">
+}
+"The " { $vocab-link "webapps.wiki" } " vocabulary defines a mix of protected and unprotected actions. One example of a protected action is that for deleting wiki pages, an action normally reserved for administrators. This action is protected with the following code:"
+{ $code
+ <" <protected>
+ "delete wiki articles" >>description
+ { can-delete-wiki-articles? } >>capabilities">
+}
+"The " { $vocab-link "websites.concatenative" } " vocabulary wraps all of its responders, including the wiki, in a login authentication realm:"
+{ $code
+<" : <login-config> ( responder -- responder' )
+ "Factor website" <login-realm>
+ "Factor website" >>name
+ allow-registration
+ allow-password-recovery
+ allow-edit-profile
+ allow-deactivation ;">
+} ;
+
+ARTICLE: "furnace.auth" "Furnace authentication"
+"The " { $vocab-link "furnace.auth" } " vocabulary implements a pluggable authentication framework."
+$nl
+"Usernames and passwords are verified using an " { $emphasis "authentication provider" } "."
+{ $subsection "furnace.auth.providers" }
+"Users have capabilities assigned to them."
+{ $subsection "furnace.auth.capabilities" }
+"An " { $emphasis "authentication realm" } " is a responder which manages access to protected resources."
+{ $subsection "furnace.auth.realms" }
+"Actions contained inside an authentication realm can be protected by wrapping them with a responder."
+{ $subsection "furnace.auth.protected" }
+"Actions contained inside an authentication realm can access the currently logged-in user profile."
+{ $subsection "furnace.auth.users" }
+"Authentication realms can be adorned with additional functionality."
+{ $subsection "furnace.auth.features" }
+"An administration tool."
+{ $subsection "furnace.auth.user-admin" }
+"A concrete example."
+{ $subsection "furnace.auth.example" } ;
+
+ABOUT: "furnace.auth"
diff --git a/basis/furnace/auth/features/recover-password/recover-password.factor b/basis/furnace/auth/features/recover-password/recover-password.factor
index 49e692d5a6..5885aaef61 100644
--- a/basis/furnace/auth/features/recover-password/recover-password.factor
+++ b/basis/furnace/auth/features/recover-password/recover-password.factor
@@ -110,7 +110,7 @@ SYMBOL: lost-password-from
<page-action>
{ realm "features/recover-password/recover-4" } >>template ;
-: allow-password-recovery ( login -- login )
+: allow-password-recovery ( realm -- realm )
<recover-action-1> <auth-boilerplate>
"recover-password" add-responder
<recover-action-2> <auth-boilerplate>
diff --git a/basis/furnace/furnace-docs.factor b/basis/furnace/furnace-docs.factor
index 57181ff0e9..421e13ac95 100644
--- a/basis/furnace/furnace-docs.factor
+++ b/basis/furnace/furnace-docs.factor
@@ -1,4 +1,5 @@
-USING: assocs help.markup help.syntax io.streams.string quotations sequences strings urls ;
+USING: assocs help.markup help.syntax kernel
+quotations sequences strings urls ;
IN: furnace
HELP: adjust-redirect-url
@@ -193,6 +194,7 @@ ARTICLE: "furnace" "Furnace framework"
{ $subsection "furnace.alloy" }
{ $subsection "furnace.persistence" }
{ $subsection "furnace.presentation" }
+{ $subsection "furnace.auth" }
{ $subsection "furnace.load-balancing" }
"Utilities:"
{ $subsection "furnace.referrer" }
diff --git a/basis/furnace/furnace.factor b/basis/furnace/furnace.factor
index a77b0d28c7..175c7ddbe2 100644
--- a/basis/furnace/furnace.factor
+++ b/basis/furnace/furnace.factor
@@ -152,3 +152,4 @@ USE: vocabs.loader
"furnace.scopes" require
"furnace.sessions" require
"furnace.syndication" require
+"webapps.user-admin" require
diff --git a/basis/furnace/summary.txt b/basis/furnace/summary.txt
new file mode 100644
index 0000000000..afbc1b9b2c
--- /dev/null
+++ b/basis/furnace/summary.txt
@@ -0,0 +1 @@
+Furnace web framework
From 9e23fe2df43108575e774a224c70a8e93a7ca260 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 08:39:18 -0600
Subject: [PATCH 118/157] Document webapps.user-admin
---
.../webapps/user-admin/user-admin-docs.factor | 22 +++++++++++++++++++
1 file changed, 22 insertions(+)
create mode 100644 extra/webapps/user-admin/user-admin-docs.factor
diff --git a/extra/webapps/user-admin/user-admin-docs.factor b/extra/webapps/user-admin/user-admin-docs.factor
new file mode 100644
index 0000000000..3551210664
--- /dev/null
+++ b/extra/webapps/user-admin/user-admin-docs.factor
@@ -0,0 +1,22 @@
+USING: help.markup help.syntax db strings ;
+IN: webapps.user-admin
+
+HELP: <user-admin>
+{ $values { "responder" "a new responder" } }
+{ $description "Creates a new instance of the user admin tool. This tool must be added to an authentication realm, and access is restricted to users having the " { $link can-administer-users? } " capability." } ;
+
+HELP: can-administer-users?
+{ $description "A user capability. Users having this capability may use the " { $link user-admin } " tool." }
+{ $notes "See " { $link "furnace.auth.capabilities" } " for information about capabilities." } ;
+
+HELP: make-admin
+{ $values { "username" string } }
+{ $description "Makes an existing user into an administrator by giving them the " { $link can-administer-users? } " capability, thus allowing them to use the user admin tool." } ;
+
+ARTICLE: "furnace.auth.user-admin" "Furnace user administration tool"
+"The " { $vocab-link "webapps.user-admin" } " vocabulary implements a web application for adding, removing and editing users in authentication realms that use " { $link "furnace.auth.providers.db" } "."
+{ $subsection <user-admin> }
+"Access to the web app itself is protected, and only users having an administrative capability can access it:"
+{ $subsection can-administer-users? }
+"To make an existing user an administrator, call the following word in a " { $link with-db } " scope:"
+{ $subsection make-admin } ;
From 9bf63b1613de29067a810a568214d8c37404d6f4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 09:03:30 -0600
Subject: [PATCH 119/157] New $quotation markup element
---
basis/alien/c-types/c-types-docs.factor | 4 +-
basis/binary-search/binary-search-docs.factor | 2 +-
basis/cocoa/messages/messages-docs.factor | 2 +-
.../combinators/combinators-docs.factor | 10 ++--
basis/concurrency/futures/futures-docs.factor | 2 +-
.../mailboxes/mailboxes-docs.factor | 27 +++++------
basis/documents/documents-docs.factor | 2 +-
basis/furnace/auth/auth-docs.factor | 2 +-
.../conversations/conversations-docs.factor | 2 +-
basis/furnace/furnace-docs.factor | 34 ++-----------
basis/furnace/furnace.factor | 2 +-
basis/furnace/sessions/sessions-docs.factor | 2 +-
basis/help/help-docs.factor | 40 ++++++++++++++--
basis/help/html/html.factor | 1 +
basis/help/markup/markup.factor | 7 ++-
basis/html/templates/chloe/chloe-docs.factor | 4 +-
basis/http/client/client-docs.factor | 4 +-
basis/http/server/static/static-docs.factor | 2 +-
basis/io/mmap/mmap-docs.factor | 2 +-
basis/io/monitors/monitors-docs.factor | 2 +-
basis/io/pools/pools-docs.factor | 2 +-
basis/io/timeouts/timeouts-docs.factor | 2 +-
basis/libc/libc-docs.factor | 2 +-
basis/math/functions/functions-docs.factor | 2 +-
basis/models/filter/filter-docs.factor | 2 +-
basis/models/models-docs.factor | 4 +-
basis/prettyprint/backend/backend-docs.factor | 2 +-
.../prettyprint/sections/sections-docs.factor | 4 +-
basis/suffix-arrays/suffix-arrays.factor | 1 +
basis/threads/threads-docs.factor | 6 +--
.../tools/annotations/annotations-docs.factor | 2 +-
basis/tools/test/test-docs.factor | 2 +-
basis/ui/gadgets/buttons/buttons-docs.factor | 8 ++--
basis/ui/gadgets/editors/editors-docs.factor | 4 +-
basis/ui/gadgets/gadgets-docs.factor | 6 +--
.../ui/gadgets/labelled/labelled-docs.factor | 4 +-
basis/ui/gadgets/lists/lists-docs.factor | 2 +-
basis/ui/gadgets/menus/menus-docs.factor | 2 +-
basis/ui/gadgets/panes/panes-docs.factor | 2 +-
basis/ui/operations/operations-docs.factor | 4 +-
basis/ui/tools/debugger/debugger-docs.factor | 2 +-
basis/ui/ui-docs.factor | 2 +-
basis/values/values-docs.factor | 2 +-
core/assocs/assocs-docs.factor | 22 ++++-----
core/classes/predicate/predicate-docs.factor | 2 +-
core/combinators/combinators-docs.factor | 4 +-
core/continuations/continuations-docs.factor | 8 ++--
core/destructors/destructors-docs.factor | 2 +-
core/generic/generic-docs.factor | 2 +-
core/generic/math/math-docs.factor | 2 +-
core/kernel/kernel-docs.factor | 46 +++++++++---------
core/lexer/lexer-docs.factor | 2 +-
core/math/math-docs.factor | 8 ++--
core/math/order/order-docs.factor | 2 +-
core/memory/memory-docs.factor | 4 +-
core/namespaces/namespaces-docs.factor | 2 +-
core/parser/parser-docs.factor | 2 +-
core/sequences/sequences-docs.factor | 48 +++++++++----------
core/sorting/sorting-docs.factor | 2 +-
core/vocabs/vocabs-docs.factor | 2 +-
.../partial-continuations-docs.factor | 4 +-
61 files changed, 199 insertions(+), 187 deletions(-)
diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor
index 03208de63a..739b45486f 100644
--- a/basis/alien/c-types/c-types-docs.factor
+++ b/basis/alien/c-types/c-types-docs.factor
@@ -39,12 +39,12 @@ HELP: byte-length
{ $contract "Outputs the size of the byte array or float array data in bytes as presented to the C library interface." } ;
HELP: c-getter
-{ $values { "name" string } { "quot" "a quotation with stack effect " { $snippet "( c-ptr n -- obj )" } } }
+{ $values { "name" string } { "quot" { $quotation "( c-ptr n -- obj )" } } }
{ $description "Outputs a quotation which reads values of this C type from a C structure." }
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: c-setter
-{ $values { "name" string } { "quot" "a quotation with stack effect " { $snippet "( obj c-ptr n -- )" } } }
+{ $values { "name" string } { "quot" { $quotation "( obj c-ptr n -- )" } } }
{ $description "Outputs a quotation which writes values of this C type to a C structure." }
{ $errors "Throws an error if the type does not exist." } ;
diff --git a/basis/binary-search/binary-search-docs.factor b/basis/binary-search/binary-search-docs.factor
index caabbd7419..cf7915159a 100644
--- a/basis/binary-search/binary-search-docs.factor
+++ b/basis/binary-search/binary-search-docs.factor
@@ -2,7 +2,7 @@ IN: binary-search
USING: help.markup help.syntax sequences kernel math.order ;
HELP: search
-{ $values { "seq" "a sorted sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- <=> )" } } { "i" "an index, or " { $link f } } { "elt" "an element, or " { $link f } } }
+{ $values { "seq" "a sorted sequence" } { "quot" { $quotation "( elt -- <=> )" } } { "i" "an index, or " { $link f } } { "elt" "an element, or " { $link f } } }
{ $description "Performs a binary search on a sequence, calling the quotation to decide whether to end the search (" { $link +eq+ } "), search lower (" { $link +lt+ } ") or search higher (" { $link +gt+ } ")."
$nl
"If the sequence is non-empty, outputs the index and value of the closest match, which is either an element for which the quotation output " { $link +eq+ } ", or failing that, least element for which the quotation output " { $link +lt+ } "."
diff --git a/basis/cocoa/messages/messages-docs.factor b/basis/cocoa/messages/messages-docs.factor
index 9b5e3fdfd9..400599383f 100644
--- a/basis/cocoa/messages/messages-docs.factor
+++ b/basis/cocoa/messages/messages-docs.factor
@@ -31,7 +31,7 @@ HELP: alien>objc-types
{ objc>alien-types alien>objc-types } related-words
HELP: import-objc-class
-{ $values { "name" string } { "quot" "a quotation with stack effect " { $snippet "( -- )" } } }
+{ $values { "name" string } { "quot" { $quotation "( -- )" } } }
{ $description "If a class named " { $snippet "name" } " is already known to the Objective C interface, does nothing. Otherwise, first calls the quotation. The quotation should make the class available to the Objective C runtime if necessary, either by loading a framework or defining it directly. After the quotation returns, this word makes the class available to Factor programs by importing methods and creating a class word the class object in the " { $vocab-link "cocoa.classes" } " vocabulary." } ;
HELP: root-class
diff --git a/basis/concurrency/combinators/combinators-docs.factor b/basis/concurrency/combinators/combinators-docs.factor
index a23301c1e2..cb07e5a8d6 100644
--- a/basis/concurrency/combinators/combinators-docs.factor
+++ b/basis/concurrency/combinators/combinators-docs.factor
@@ -2,27 +2,27 @@ USING: help.markup help.syntax sequences ;
IN: concurrency.combinators
HELP: parallel-map
-{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } { "newseq" sequence } }
+{ $values { "seq" sequence } { "quot" { $quotation "( elt -- newelt )" } } { "newseq" sequence } }
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the results at the end." }
{ $errors "Throws an error if one of the iterations throws an error." } ;
HELP: 2parallel-map
-{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } { "newseq" sequence } }
+{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt -- newelt )" } } { "newseq" sequence } }
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to pairwise elements of " { $snippet "seq1" } " and " { $snippet "seq2" } ", collecting the results at the end." }
{ $errors "Throws an error if one of the iterations throws an error." } ;
HELP: parallel-each
-{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }
+{ $values { "seq" sequence } { "quot" { $quotation "( elt -- )" } } }
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", blocking until all quotations complete." }
{ $errors "Throws an error if one of the iterations throws an error." } ;
HELP: 2parallel-each
-{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }
+{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt -- )" } } }
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to pairwise elements of " { $snippet "seq1" } " and " { $snippet "seq2" } ", blocking until all quotations complete." }
{ $errors "Throws an error if one of the iterations throws an error." } ;
HELP: parallel-filter
-{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "newseq" sequence } }
+{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "newseq" sequence } }
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the elements for which the quotation yielded a true value." }
{ $errors "Throws an error if one of the iterations throws an error." } ;
diff --git a/basis/concurrency/futures/futures-docs.factor b/basis/concurrency/futures/futures-docs.factor
index 99b4bb6e81..22549c1720 100644
--- a/basis/concurrency/futures/futures-docs.factor
+++ b/basis/concurrency/futures/futures-docs.factor
@@ -5,7 +5,7 @@ continuations help.markup help.syntax quotations ;
IN: concurrency.futures
HELP: future
-{ $values { "quot" "a quotation with stack effect " { $snippet "( -- value )" } } { "future" future } }
+{ $values { "quot" { $quotation "( -- value )" } } { "future" future } }
{ $description "Creates a deferred computation."
$nl
"The quotation begins with an empty data stack, an empty catch stack, and a name stack containing the global namespace only. This means that the only way to pass data to the quotation is to partially apply the data, for example using " { $link curry } " or " { $link compose } "." } ;
diff --git a/basis/concurrency/mailboxes/mailboxes-docs.factor b/basis/concurrency/mailboxes/mailboxes-docs.factor
index a9b86e3bcd..234fb27d60 100644
--- a/basis/concurrency/mailboxes/mailboxes-docs.factor
+++ b/basis/concurrency/mailboxes/mailboxes-docs.factor
@@ -1,4 +1,4 @@
-USING: help.markup help.syntax kernel arrays ;
+USING: help.markup help.syntax kernel arrays calendar ;
IN: concurrency.mailboxes
HELP: <mailbox>
@@ -18,46 +18,41 @@ HELP: mailbox-put
{ $description "Put the object into the mailbox. Any threads that have a blocking get on the mailbox are resumed. Only one of those threads will successfully get the object, the rest will immediately block waiting for the next item in the mailbox." } ;
HELP: block-unless-pred
-{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } }
- { "mailbox" mailbox }
- { "timeout" "a timeout in milliseconds, or " { $link f } }
+{ $values { "pred" { $quotation "( obj -- ? )" } }
+ { "mailbox" mailbox }
+ { "timeout" "a " { $link duration } " or " { $link f } }
}
{ $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack." } ;
HELP: block-if-empty
{ $values { "mailbox" mailbox }
- { "timeout" "a timeout in milliseconds, or " { $link f } }
+ { "timeout" "a " { $link duration } " or " { $link f } }
}
{ $description "Block the thread if the mailbox is empty." } ;
HELP: mailbox-get
-{ $values { "mailbox" mailbox }
- { "obj" object }
-}
+{ $values { "mailbox" mailbox } { "obj" object } }
{ $description "Get the first item put into the mailbox. If it is empty the thread blocks until an item is put into it. The thread then resumes, leaving the item on the stack." } ;
HELP: mailbox-get-all
-{ $values { "mailbox" mailbox }
- { "array" array }
-}
+{ $values { "mailbox" mailbox } { "array" array } }
{ $description "Blocks the thread if the mailbox is empty, otherwise removes all objects in the mailbox and returns an array containing the objects." } ;
HELP: while-mailbox-empty
{ $values { "mailbox" mailbox }
- { "quot" "a quotation with stack effect " { $snippet "( -- )" } }
+ { "quot" { $quotation "( -- )" } }
}
{ $description "Repeatedly call the quotation while there are no items in the mailbox." } ;
HELP: mailbox-get?
{ $values { "mailbox" mailbox }
- { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } }
+ { "pred" { $quotation "( obj -- ? )" } }
{ "obj" object }
}
-{ $description "Get the first item in the mailbox which satisfies the predicate. 'pred' will be called repeatedly for each item in the mailbox. When 'pred' returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } ;
-
+{ $description "Get the first item in the mailbox which satisfies the predicate. When the predicate returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } ;
ARTICLE: "concurrency.mailboxes" "Mailboxes"
-"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty, instead of throwing an error. Mailboxes are implemented in the " { $vocab-link "concurrency.mailboxes" } " vocabulary."
+"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty. Mailboxes are implemented in the " { $vocab-link "concurrency.mailboxes" } " vocabulary."
{ $subsection mailbox }
{ $subsection <mailbox> }
"Removing the first element:"
diff --git a/basis/documents/documents-docs.factor b/basis/documents/documents-docs.factor
index 61fab306a2..974645b284 100644
--- a/basis/documents/documents-docs.factor
+++ b/basis/documents/documents-docs.factor
@@ -42,7 +42,7 @@ HELP: doc-lines
{ $errors "Throws an error if " { $snippet "from" } " or " { $snippet "to" } " is out of bounds." } ;
HELP: each-line
-{ $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "quot" "a quotation with stack effect " { $snippet "( string -- )" } } }
+{ $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "quot" { $quotation "( string -- )" } } }
{ $description "Applies the quotation to each line in the range." }
{ $notes "The range is created by calling " { $link <slice> } "." }
{ $errors "Throws an error if " { $snippet "from" } " or " { $snippet "to" } " is out of bounds." } ;
diff --git a/basis/furnace/auth/auth-docs.factor b/basis/furnace/auth/auth-docs.factor
index 210254aa15..e7e722344a 100644
--- a/basis/furnace/auth/auth-docs.factor
+++ b/basis/furnace/auth/auth-docs.factor
@@ -63,7 +63,7 @@ HELP: realm
{ $class-description "The class of authentication realms. See " { $link "furnace.auth.realms" } " for details." } ;
HELP: uchange
-{ $values { "key" symbol } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } }
+{ $values { "key" symbol } { "quot" { $quotation "( old -- new )" } } }
{ $description "Applies the quotation to the old value of the user profile variable, and assigns the resulting value back to the variable." } ;
HELP: uget
diff --git a/basis/furnace/conversations/conversations-docs.factor b/basis/furnace/conversations/conversations-docs.factor
index 60844fadae..4ad2c8a249 100644
--- a/basis/furnace/conversations/conversations-docs.factor
+++ b/basis/furnace/conversations/conversations-docs.factor
@@ -28,7 +28,7 @@ HELP: cset
{ $description "Sets the value of a conversation variable." } ;
HELP: cchange
-{ $values { "key" symbol } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } }
+{ $values { "key" symbol } { "quot" { $quotation "( old -- new )" } } }
{ $description "Applies the quotation to the old value of the conversation variable, and assigns the resulting value back to the variable." } ;
ARTICLE: "furnace.conversations" "Furnace conversation scope"
diff --git a/basis/furnace/furnace-docs.factor b/basis/furnace/furnace-docs.factor
index 421e13ac95..4b8c877ca8 100644
--- a/basis/furnace/furnace-docs.factor
+++ b/basis/furnace/furnace-docs.factor
@@ -3,47 +3,23 @@ quotations sequences strings urls ;
IN: furnace
HELP: adjust-redirect-url
-{ $values
- { "url" url }
- { "url'" url }
-}
+{ $values { "url" url } { "url'" url } }
{ $description "" } ;
HELP: adjust-url
-{ $values
- { "url" url }
- { "url'" url }
-}
+{ $values { "url" url } { "url'" url } }
{ $description "" } ;
HELP: base-path
-{ $values
- { "string" string }
- { "pair" null }
-}
+{ $values { "string" string } { "pair" "a pair with shape " { $snippet "{ path responder }" } } }
{ $description "" } ;
HELP: client-state
-{ $values
- { "key" null }
- { "value/f" null }
-}
-{ $description "" } ;
-
-HELP: cookie-client-state
-{ $values
- { "key" null } { "request" null }
- { "value/f" null }
-}
+{ $values { "key" string } { "value/f" { $maybe string } } }
{ $description "" } ;
HELP: each-responder
-{ $values
- { "quot" quotation }
-}
-{ $description "" } ;
-
-HELP: exit-continuation
+{ $values { "quot" "a " { $link quotation } " with stack effect " { $snippet "( responder -- )" } } }
{ $description "" } ;
HELP: exit-with
diff --git a/basis/furnace/furnace.factor b/basis/furnace/furnace.factor
index 175c7ddbe2..841a7087c3 100644
--- a/basis/furnace/furnace.factor
+++ b/basis/furnace/furnace.factor
@@ -90,7 +90,7 @@ M: object modify-form drop ;
} case ;
: referrer ( -- referrer/f )
- #! Typo is intentional, its in the HTTP spec!
+ #! Typo is intentional, it's in the HTTP spec!
"referer" request get header>> at
dup [ >url ensure-port [ remap-port ] change-port ] when ;
diff --git a/basis/furnace/sessions/sessions-docs.factor b/basis/furnace/sessions/sessions-docs.factor
index 778452edc2..959d6b69b8 100644
--- a/basis/furnace/sessions/sessions-docs.factor
+++ b/basis/furnace/sessions/sessions-docs.factor
@@ -9,7 +9,7 @@ HELP: <sessions>
{ $description "Wraps a responder in a session manager responder." } ;
HELP: schange
-{ $values { "key" symbol } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } }
+{ $values { "key" symbol } { "quot" { $quotation "( old -- new )" } } }
{ $description "Applies the quotation to the old value of the session variable, and assigns the resulting value back to the variable." } ;
HELP: sget
diff --git a/basis/help/help-docs.factor b/basis/help/help-docs.factor
index 2fe4edfe7f..277d965e39 100644
--- a/basis/help/help-docs.factor
+++ b/basis/help/help-docs.factor
@@ -1,6 +1,6 @@
USING: help.markup help.crossref help.stylesheet help.topics
help.syntax definitions io prettyprint summary arrays math
-sequences vocabs ;
+sequences vocabs strings ;
IN: help
ARTICLE: "printing-elements" "Printing markup elements"
@@ -33,6 +33,10 @@ ARTICLE: "block-elements" "Block elements"
{ $subsection $side-effects }
{ $subsection $errors }
{ $subsection $see-also }
+"Elements used in " { $link $values } " forms:"
+{ $subsection $instance }
+{ $subsection $maybe }
+{ $subsection $quotation }
"Boilerplate paragraphs:"
{ $subsection $low-level-note }
{ $subsection $io-error }
@@ -281,7 +285,7 @@ HELP: $link
} ;
HELP: textual-list
-{ $values { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }
+{ $values { "seq" "a sequence" } { "quot" { $quotation "( elt -- )" } } }
{ $description "Applies the quotation to each element of the sequence, printing a comma between each pair of elements." }
{ $examples
{ $example "USING: help.markup io ;" "{ \"fish\" \"chips\" \"salt\" } [ write ] textual-list" "fish, chips, salt" }
@@ -318,7 +322,37 @@ HELP: $table
HELP: $values
{ $values { "element" "an array of pairs of markup elements" } }
-{ $description "Prints the description of arguments and values found on every word help page. The first element of a pair is the argument name and is output with " { $link $snippet } ". The remainder can be an element of any form." } ;
+{ $description "Prints the description of arguments and values found on every word help page. The first element of a pair is the argument name and is output with " { $link $snippet } ". The remainder is either a single class word, or an element. If it is a class word " { $snippet "class" } ", it is intereted as if it were shorthand for " { $snippet "{ $instance class }" } "." }
+{ $see-also $maybe $instance $quotation } ;
+
+HELP: $instance
+{ $values { "element" "an array with shape " { $snippet "{ class }" } } }
+{ $description
+ "Produces the text ``a " { $emphasis "class" } "'' or ``an " { $emphasis "class" } "'', depending on the first letter of " { $emphasis "class" } "."
+}
+{ $examples
+ { $markup-example { $instance string } }
+ { $markup-example { $instance integer } }
+ { $markup-example { $instance f } }
+} ;
+
+HELP: $maybe
+{ $values { "element" "an array with shape " { $snippet "{ class }" } } }
+{ $description
+ "Produces the text ``a " { $emphasis "class" } " or f'' or ``an " { $emphasis "class" } " or f'', depending on the first letter of " { $emphasis "class" } "."
+}
+{ $examples
+ { $markup-example { $maybe string } }
+} ;
+
+HELP: $quotation
+{ $values { "element" "an array with shape " { $snippet "{ effect }" } } }
+{ $description
+ "Produces the text ``a quotation with stack effect " { $emphasis "effect" } "''."
+}
+{ $examples
+ { $markup-example { $quotation "( obj -- )" } }
+} ;
HELP: $list
{ $values { "element" "an array of markup elements" } }
diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor
index 386dca9576..8cefb4c112 100644
--- a/basis/help/html/html.factor
+++ b/basis/help/html/html.factor
@@ -22,6 +22,7 @@ IN: help.html
{ CHAR: / "__slash__" }
{ CHAR: \\ "__backslash__" }
{ CHAR: , "__comma__" }
+ { CHAR: @ "__at__" }
} at [ % ] [ , ] ?if ;
: escape-filename ( string -- filename )
diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor
index 4410a6f780..ae3c3fa7de 100644
--- a/basis/help/markup/markup.factor
+++ b/basis/help/markup/markup.factor
@@ -3,7 +3,8 @@
USING: accessors arrays definitions generic io kernel assocs
hashtables namespaces make parser prettyprint sequences strings
io.styles vectors words math sorting splitting classes slots
-vocabs help.stylesheet help.topics vocabs.loader alias ;
+vocabs help.stylesheet help.topics vocabs.loader alias
+quotations ;
IN: help.markup
! Simple markup language.
@@ -253,6 +254,10 @@ M: f ($instance)
: $maybe ( children -- )
$instance " or " print-element { f } $instance ;
+: $quotation ( children -- )
+ { "a " { $link quotation } " with stack effect " } print-element
+ $snippet ;
+
: values-row ( seq -- seq )
unclip \ $snippet swap ?word-name 2array
swap dup first word? [ \ $instance prefix ] when 2array ;
diff --git a/basis/html/templates/chloe/chloe-docs.factor b/basis/html/templates/chloe/chloe-docs.factor
index a0faecd743..1f2975bce1 100644
--- a/basis/html/templates/chloe/chloe-docs.factor
+++ b/basis/html/templates/chloe/chloe-docs.factor
@@ -24,7 +24,7 @@ HELP: compile-attr
HELP: CHLOE:
{ $syntax "name definition... ;" }
-{ $values { "name" "the tag name" } { "definition" "a quotation with stack effect " { $snippet "( tag -- )" } } }
+{ $values { "name" "the tag name" } { "definition" { $quotation "( tag -- )" } } }
{ $description "Defines compilation semantics for the Chloe tag named " { $snippet "tag" } ". The definition body receives a " { $link tag } " on the stack." } ;
HELP: COMPONENT:
@@ -46,7 +46,7 @@ HELP: [code]
{ $description "Compiles the quotation. It will be called when the template is called." } ;
HELP: process-children
-{ $values { "tag" tag } { "quot" "a quotation with stack effect " { $snippet "( compiled-tag -- )" } } }
+{ $values { "tag" tag } { "quot" { $quotation "( compiled-tag -- )" } } }
{ $description "Compiles the tag. The quotation will be applied to the resulting quotation when the template is called." }
{ $examples "See " { $link "html.templates.chloe.extend.tags.example" } " for an example which uses this word to implement a custom control flow tag." } ;
diff --git a/basis/http/client/client-docs.factor b/basis/http/client/client-docs.factor
index d4f277a7c3..7a35ba812b 100644
--- a/basis/http/client/client-docs.factor
+++ b/basis/http/client/client-docs.factor
@@ -40,7 +40,7 @@ HELP: http-post
{ $errors "Throws an error if the HTTP request fails." } ;
HELP: with-http-get
-{ $values { "url" "a " { $link url } " or " { $link string } } { "quot" "a quotation with stack effect " { $snippet "( chunk -- )" } } { "response" response } }
+{ $values { "url" "a " { $link url } " or " { $link string } } { "quot" { $quotation "( chunk -- )" } } { "response" response } }
{ $description "Downloads the contents of a URL. Chunks of data are passed to the quotation as they are read." }
{ $errors "Throws an error if the HTTP request fails." } ;
@@ -50,7 +50,7 @@ HELP: http-request
{ $errors "Throws an error if the HTTP request fails." } ;
HELP: with-http-request
-{ $values { "request" request } { "quot" "a quotation with stack effect " { $snippet "( chunk -- )" } } { "response" response } }
+{ $values { "request" request } { "quot" { $quotation "( chunk -- )" } } { "response" response } }
{ $description "Sends an HTTP request to an HTTP server, and reads the response incrementally. Chunks of data are passed to the quotation as they are read." }
{ $errors "Throws an error if the HTTP request fails." } ;
diff --git a/basis/http/server/static/static-docs.factor b/basis/http/server/static/static-docs.factor
index bca72a6126..fbe20b5fcd 100644
--- a/basis/http/server/static/static-docs.factor
+++ b/basis/http/server/static/static-docs.factor
@@ -4,7 +4,7 @@ USING: help.markup help.syntax io.streams.string ;
IN: http.server.static
HELP: <file-responder>
-{ $values { "root" "a pathname string" } { "hook" "a quotation with stack effect " { $snippet "( path mime-type -- response )" } } { "responder" file-responder } }
+{ $values { "root" "a pathname string" } { "hook" { $quotation "( path mime-type -- response )" } } { "responder" file-responder } }
{ $description "Creates a file responder which serves content from " { $snippet "path" } " by using the hook to generate a response." } ;
HELP: <static>
diff --git a/basis/io/mmap/mmap-docs.factor b/basis/io/mmap/mmap-docs.factor
index c774103fca..09922fc929 100644
--- a/basis/io/mmap/mmap-docs.factor
+++ b/basis/io/mmap/mmap-docs.factor
@@ -17,7 +17,7 @@ HELP: <mapped-file>
{ $errors "Throws an error if a memory mapping could not be established." } ;
HELP: with-mapped-file
-{ $values { "path" "a pathname string" } { "length" integer } { "quot" "a quotation with stack effect " { $snippet "( mmap -- )" } } }
+{ $values { "path" "a pathname string" } { "length" integer } { "quot" { $quotation "( mmap -- )" } } }
{ $contract "Opens a file and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
{ $errors "Throws an error if a memory mapping could not be established." } ;
diff --git a/basis/io/monitors/monitors-docs.factor b/basis/io/monitors/monitors-docs.factor
index ce59e23b45..3242b276e6 100644
--- a/basis/io/monitors/monitors-docs.factor
+++ b/basis/io/monitors/monitors-docs.factor
@@ -23,7 +23,7 @@ HELP: next-change
{ $errors "Throws an error if the monitor is closed from another thread." } ;
HELP: with-monitor
-{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } }
+{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" { $quotation "( monitor -- )" } } }
{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." }
{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;
diff --git a/basis/io/pools/pools-docs.factor b/basis/io/pools/pools-docs.factor
index aae1698349..36f437dd09 100644
--- a/basis/io/pools/pools-docs.factor
+++ b/basis/io/pools/pools-docs.factor
@@ -22,7 +22,7 @@ HELP: return-connection
{ $description "Returns a connection to the pool." } ;
HELP: with-pooled-connection
-{ $values { "pool" pool } { "quot" "a quotation with stack effect " { $snippet "( conn -- )" } } }
+{ $values { "pool" pool } { "quot" { $quotation "( conn -- )" } } }
{ $description "Calls a quotation with a pooled connection on the stack. If the quotation returns successfully, the connection is returned to the pool; if the quotation throws an error, the connection is disposed of with " { $link dispose } "." } ;
HELP: make-connection
diff --git a/basis/io/timeouts/timeouts-docs.factor b/basis/io/timeouts/timeouts-docs.factor
index fcaab80958..5d72bde0f5 100644
--- a/basis/io/timeouts/timeouts-docs.factor
+++ b/basis/io/timeouts/timeouts-docs.factor
@@ -14,7 +14,7 @@ HELP: cancel-operation
{ $contract "Handles a timeout, usually by waking up all threads waiting on the object." } ;
HELP: with-timeout
-{ $values { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } }
+{ $values { "obj" object } { "quot" { $quotation "( obj -- )" } } }
{ $description "Applies the quotation to the object. If the object's timeout expires before the quotation returns, " { $link cancel-operation } " is called on the object." } ;
ARTICLE: "io.timeouts" "I/O timeout protocol"
diff --git a/basis/libc/libc-docs.factor b/basis/libc/libc-docs.factor
index 5e285bf26d..37a3b7068f 100644
--- a/basis/libc/libc-docs.factor
+++ b/basis/libc/libc-docs.factor
@@ -33,7 +33,7 @@ HELP: free
{ $description "Deallocates a block of memory allocated by " { $link malloc } ", " { $link calloc } " or " { $link realloc } "." } ;
HELP: with-malloc
-{ $values { "size" "a positive integer" } { "quot" "a quotation with stack effect " { $snippet "( c-ptr -- )" } } }
+{ $values { "size" "a positive integer" } { "quot" { $quotation "( c-ptr -- )" } } }
{ $description "Allocates a zeroed block of " { $snippet "n" } " bytes and passes it to the quotation. When the quotation returns, the block is freed." } ;
HELP: &free
diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor
index f9bb8e9897..ea3da55082 100644
--- a/basis/math/functions/functions-docs.factor
+++ b/basis/math/functions/functions-docs.factor
@@ -279,7 +279,7 @@ HELP: mod-inv
} ;
HELP: each-bit
-{ $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( ? -- )" } } }
+{ $values { "n" integer } { "quot" { $quotation "( ? -- )" } } }
{ $description "Applies the quotation to each bit of the integer, starting from the least significant bit, and stopping at the last bit from which point on all bits are either clear (if the integer is positive) or all bits are set (if the integer is negataive)." }
{ $examples
{ $example "USING: math.functions make prettyprint ;" "[ BIN: 1101 [ , ] each-bit ] { } make ." "{ t f t t }" }
diff --git a/basis/models/filter/filter-docs.factor b/basis/models/filter/filter-docs.factor
index 8c50aac65b..c3f4df3250 100644
--- a/basis/models/filter/filter-docs.factor
+++ b/basis/models/filter/filter-docs.factor
@@ -15,7 +15,7 @@ HELP: filter
} ;
HELP: <filter>
-{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "filter" "a new " { $link filter } } }
+{ $values { "model" model } { "quot" { $quotation "( obj -- newobj )" } } { "filter" "a new " { $link filter } } }
{ $description "Creates a new instance of " { $link filter } ". The value of the new filter model is computed by applying the quotation to the value." }
{ $examples "See the example in the documentation for " { $link filter } "." } ;
diff --git a/basis/models/models-docs.factor b/basis/models/models-docs.factor
index 97e4557ada..5295420ee3 100644
--- a/basis/models/models-docs.factor
+++ b/basis/models/models-docs.factor
@@ -66,11 +66,11 @@ HELP: set-model
{ set-model change-model (change-model) } related-words
HELP: change-model
-{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } }
+{ $values { "model" model } { "quot" { $quotation "( obj -- newobj )" } } }
{ $description "Applies the quotation to the current value of the model to yield a new value, then changes the value of the model to the new value, and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;
HELP: (change-model)
-{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } }
+{ $values { "model" model } { "quot" { $quotation "( obj -- newobj )" } } }
{ $description "Applies the quotation to the current value of the model to yield a new value, then changes the value of the model to the new value without notifying any observers registered with " { $link add-connection } "." }
{ $notes "There are very few reasons for user code to call this word. Instead, call " { $link change-model } ", which notifies observers." } ;
diff --git a/basis/prettyprint/backend/backend-docs.factor b/basis/prettyprint/backend/backend-docs.factor
index cc4f5cedb5..64e1fd45ff 100644
--- a/basis/prettyprint/backend/backend-docs.factor
+++ b/basis/prettyprint/backend/backend-docs.factor
@@ -37,7 +37,7 @@ HELP: nesting-limit?
$prettyprinting-note ;
HELP: check-recursion
-{ $values { "obj" "an object" } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } }
+{ $values { "obj" "an object" } { "quot" { $quotation "( obj -- )" } } }
{ $description "If the object is already being printed, that is, if the prettyprinter has encountered a cycle in the object graph, or if the maximum nesting depth has been reached, outputs a dummy string. Otherwise applies the quotation to the object." }
$prettyprinting-note ;
diff --git a/basis/prettyprint/sections/sections-docs.factor b/basis/prettyprint/sections/sections-docs.factor
index 842a36a13b..4f1c073a2d 100644
--- a/basis/prettyprint/sections/sections-docs.factor
+++ b/basis/prettyprint/sections/sections-docs.factor
@@ -145,7 +145,7 @@ HELP: save-end-position
{ $description "Save the current position as the end position of the block." } ;
HELP: pprint-sections
-{ $values { "block" block } { "advancer" "a quotation with stack effect " { $snippet "( block -- )" } } }
+{ $values { "block" block } { "advancer" { $quotation "( block -- )" } } }
{ $description "Prints child sections of a block, ignoring any " { $link line-break } " sections. The " { $snippet "advancer" } " quotation is called between every pair of sections." } ;
HELP: do-break
@@ -157,7 +157,7 @@ HELP: empty-block?
{ $description "Tests if the block has no child sections." } ;
HELP: if-nonempty
-{ $values { "block" block } { "quot" "a quotation with stack effect " { $snippet "( block -- )" } } }
+{ $values { "block" block } { "quot" { $quotation "( block -- )" } } }
{ $description "If the block has child sections, calls the quotation, otherwise does nothing." } ;
HELP: (<block)
diff --git a/basis/suffix-arrays/suffix-arrays.factor b/basis/suffix-arrays/suffix-arrays.factor
index b181ba9d60..fa68cc0a8e 100755
--- a/basis/suffix-arrays/suffix-arrays.factor
+++ b/basis/suffix-arrays/suffix-arrays.factor
@@ -5,6 +5,7 @@ math.vectors math.order sorting binary-search sets assocs fry ;
IN: suffix-arrays
<PRIVATE
+
: suffixes ( string -- suffixes-seq )
dup length [ tail-slice ] with map ;
diff --git a/basis/threads/threads-docs.factor b/basis/threads/threads-docs.factor
index f6f102c4b4..471cd2bd34 100644
--- a/basis/threads/threads-docs.factor
+++ b/basis/threads/threads-docs.factor
@@ -129,7 +129,7 @@ HELP: interrupt
{ $description "Interrupts a sleeping thread." } ;
HELP: suspend
-{ $values { "quot" "a quotation with stack effect " { $snippet "( thread -- )" } } { "state" string } { "obj" object } }
+{ $values { "quot" { $quotation "( thread -- )" } } { "state" string } { "obj" object } }
{ $description "Suspends the current thread and passes it to the quotation."
$nl
"After the quotation returns, control yields to the next runnable thread and the current thread does not execute again until it is resumed, and so the quotation must arrange for another thread to later resume the suspended thread with a call to " { $link resume } " or " { $link resume-with } "."
@@ -149,7 +149,7 @@ $nl
} ;
HELP: spawn-server
-{ $values { "quot" "a quotation with stack effect " { $snippet "( -- ? )" } } { "name" string } { "thread" thread } }
+{ $values { "quot" { $quotation "( -- ? )" } } { "name" string } { "thread" thread } }
{ $description "Convenience wrapper around " { $link spawn } " which repeatedly calls the quotation in a new thread until it outputs " { $link f } "." }
{ $examples
"A thread that runs forever:"
@@ -172,5 +172,5 @@ HELP: tset
{ $description "Sets the value of a thread-local variable." } ;
HELP: tchange
-{ $values { "key" object } { "quot" "a quotation with stack effect " { $snippet "( value -- newvalue )" } } }
+{ $values { "key" object } { "quot" { $quotation "( value -- newvalue )" } } }
{ $description "Applies the quotation to the current value of a thread-local variable, storing the result back to the same variable." } ;
diff --git a/basis/tools/annotations/annotations-docs.factor b/basis/tools/annotations/annotations-docs.factor
index f0a3235e62..41808d2f6a 100644
--- a/basis/tools/annotations/annotations-docs.factor
+++ b/basis/tools/annotations/annotations-docs.factor
@@ -13,7 +13,7 @@ ARTICLE: "tools.annotations" "Word annotations"
ABOUT: "tools.annotations"
HELP: annotate
-{ $values { "word" "a word" } { "quot" "a quotation with stack effect " { $snippet "( word def -- def )" } } }
+{ $values { "word" "a word" } { "quot" { $quotation "( word def -- def )" } } }
{ $description "Changes a word definition to the result of applying a quotation to the old definition." }
{ $notes "This word is used to implement " { $link watch } "." } ;
diff --git a/basis/tools/test/test-docs.factor b/basis/tools/test/test-docs.factor
index 02c0ad126d..f19ffb83a4 100644
--- a/basis/tools/test/test-docs.factor
+++ b/basis/tools/test/test-docs.factor
@@ -60,7 +60,7 @@ HELP: must-fail
{ $notes "This word is used to test boundary conditions and fail-fast behavior." } ;
HELP: must-fail-with
-{ $values { "quot" "a quotation run with an empty stack" } { "pred" "a quotation with stack effect " { $snippet "( error -- ? )" } } }
+{ $values { "quot" "a quotation run with an empty stack" } { "pred" { $quotation "( error -- ? )" } } }
{ $description "Runs a quotation with an empty stack, expecting it to throw an error which must satisfy " { $snippet "pred" } ". If the quotation does not throw an error, or if the error does not match the predicate, the unit test fails." }
{ $notes "This word is used to test error handling code, ensuring that errors thrown by code contain the relevant debugging information." } ;
diff --git a/basis/ui/gadgets/buttons/buttons-docs.factor b/basis/ui/gadgets/buttons/buttons-docs.factor
index c4edaac144..4a428404c1 100644
--- a/basis/ui/gadgets/buttons/buttons-docs.factor
+++ b/basis/ui/gadgets/buttons/buttons-docs.factor
@@ -10,19 +10,19 @@ $nl
"A button can be selected, which is distinct from being pressed. This state is held in the " { $snippet "selected?" } " slot, and is used by the " { $link <toggle-buttons> } " word to construct a row of buttons for choosing among several alternatives." } ;
HELP: <button>
-{ $values { "label" gadget } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" "a new " { $link button } } }
+{ $values { "label" gadget } { "quot" { $quotation "( button -- )" } } { "button" "a new " { $link button } } }
{ $description "Creates a new " { $link button } " which calls the quotation when clicked. The given gadget becomes the button's only child." } ;
HELP: <roll-button>
-{ $values { "label" "a label specifier" } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" button } }
+{ $values { "label" "a label specifier" } { "quot" { $quotation "( button -- )" } } { "button" button } }
{ $description "Creates a new " { $link button } " which is displayed with a solid border when it is under the mouse, informing the user that the gadget is clickable." } ;
HELP: <bevel-button>
-{ $values { "label" "a label specifier" } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" button } }
+{ $values { "label" "a label specifier" } { "quot" { $quotation "( button -- )" } } { "button" button } }
{ $description "Creates a new " { $link button } " with a shaded border which is always visible. The button appearance changes in response to mouse gestures using a " { $link button-paint } "." } ;
HELP: <repeat-button>
-{ $values { "label" object } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" repeat-button } }
+{ $values { "label" object } { "quot" { $quotation "( button -- )" } } { "button" repeat-button } }
{ $description "Creates a new " { $link button } " derived from a " { $link <bevel-button> } " which calls the quotation every 100 milliseconds as long as the mouse button is held down." } ;
HELP: button-paint
diff --git a/basis/ui/gadgets/editors/editors-docs.factor b/basis/ui/gadgets/editors/editors-docs.factor
index b691668206..0cf60ff5e8 100644
--- a/basis/ui/gadgets/editors/editors-docs.factor
+++ b/basis/ui/gadgets/editors/editors-docs.factor
@@ -41,7 +41,7 @@ HELP: editor-mark*
{ $description "Outputs the current mark location as a line/column number pair." } ;
HELP: change-caret
-{ $values { "editor" editor } { "quot" "a quotation with stack effect " { $snippet "( loc -- newloc )" } } }
+{ $values { "editor" editor } { "quot" { $quotation "( loc -- newloc )" } } }
{ $description "Applies a quotation to the current caret location and moves the caret to the location output by the quotation." } ;
{ change-caret change-caret&mark mark>caret } related-words
@@ -51,7 +51,7 @@ HELP: mark>caret
{ $description "Moves the mark to the caret location, effectively deselecting any selected text." } ;
HELP: change-caret&mark
-{ $values { "editor" editor } { "quot" "a quotation with stack effect " { $snippet "( loc -- newloc )" } } }
+{ $values { "editor" editor } { "quot" { $quotation "( loc -- newloc )" } } }
{ $description "Applies a quotation to the current caret location and moves the caret and the mark to the location output by the quotation." } ;
HELP: point>loc
diff --git a/basis/ui/gadgets/gadgets-docs.factor b/basis/ui/gadgets/gadgets-docs.factor
index 5ab20364ee..169f97f0b9 100644
--- a/basis/ui/gadgets/gadgets-docs.factor
+++ b/basis/ui/gadgets/gadgets-docs.factor
@@ -44,7 +44,7 @@ HELP: max-dim
{ pref-dims max-dim dim-sum } related-words
HELP: each-child
-{ $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( child -- )" } } }
+{ $values { "gadget" gadget } { "quot" { $quotation "( child -- )" } } }
{ $description "Applies the quotation to each child of the gadget." } ;
HELP: gadget-selection?
@@ -146,11 +146,11 @@ HELP: parents
{ $description "Outputs a sequence of all parents of the gadget, with the first element being the gadget itself." } ;
HELP: each-parent
-{ $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( gadget -- ? )" } } { "?" "a boolean" } }
+{ $values { "gadget" gadget } { "quot" { $quotation "( gadget -- ? )" } } { "?" "a boolean" } }
{ $description "Applies the quotation to every parent of the gadget, starting from the gadget itself, stopping if the quotation yields " { $link f } ". Outputs " { $link t } " if the iteration completed, and outputs " { $link f } " if it was stopped prematurely." } ;
HELP: find-parent
-{ $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( gadget -- ? )" } } { "parent" gadget } }
+{ $values { "gadget" gadget } { "quot" { $quotation "( gadget -- ? )" } } { "parent" gadget } }
{ $description "Outputs the first parent of the gadget, starting from the gadget itself, for which the quotation outputs a true value, or " { $link f } " if the quotation outputs " { $link f } " for every parent." } ;
HELP: screen-loc
diff --git a/basis/ui/gadgets/labelled/labelled-docs.factor b/basis/ui/gadgets/labelled/labelled-docs.factor
index f09bcaa825..4ad14abfd1 100644
--- a/basis/ui/gadgets/labelled/labelled-docs.factor
+++ b/basis/ui/gadgets/labelled/labelled-docs.factor
@@ -13,12 +13,12 @@ HELP: closable-gadget
{ $class-description "A closable gadget displays a title bar with a close box on top of another gadget. Clicking the close box invokes a quotation. Closable gadgets are created by calling " { $link <closable-gadget> } "." } ;
HELP: <closable-gadget>
-{ $values { "gadget" gadget } { "title" string } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } }
+{ $values { "gadget" gadget } { "title" string } { "quot" { $quotation "( button -- )" } } }
{ $description "Creates a new " { $link closable-gadget } ". Clicking the close box calls " { $snippet "quot" } "." }
{ $notes "The quotation can find the " { $link closable-gadget } " instance, or any other parent gadget by calling " { $link find-parent } " with the gadget it receives on the stack." } ;
HELP: <labelled-pane>
-{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( value -- )" } } { "scrolls?" "a boolean" } { "title" string } { "gadget" "a new " { $link gadget } } }
+{ $values { "model" model } { "quot" { $quotation "( value -- )" } } { "scrolls?" "a boolean" } { "title" string } { "gadget" "a new " { $link gadget } } }
{ $description "Creates a new control delegating to a " { $link pane } ", and wraps it in a " { $link labelled-gadget } ". When the value of the model changes, the value is pushed on the stack and the quotation is called using " { $link with-pane } "." } ;
{ <labelled-pane> <pane-control> } related-words
diff --git a/basis/ui/gadgets/lists/lists-docs.factor b/basis/ui/gadgets/lists/lists-docs.factor
index b698d558ad..6341e09505 100644
--- a/basis/ui/gadgets/lists/lists-docs.factor
+++ b/basis/ui/gadgets/lists/lists-docs.factor
@@ -14,7 +14,7 @@ HELP: list
} ;
HELP: <list>
-{ $values { "hook" "a quotation with stack effect " { $snippet "( list -- )" } } { "presenter" "a quotation with stack effect " { $snippet "( object -- label )" } } { "model" model } { "gadget" list } }
+{ $values { "hook" { $quotation "( list -- )" } } { "presenter" { $quotation "( object -- label )" } } { "model" model } { "gadget" list } }
{ $description "Creates a new " { $link list } "."
$nl
"The model value must be a sequence. The list displays presentations of elements with labels obtained by applying the " { $snippet "presenter" } " quotation to each object. The " { $snippet "hook" } " quotation is called when a presentation is selected." } ;
diff --git a/basis/ui/gadgets/menus/menus-docs.factor b/basis/ui/gadgets/menus/menus-docs.factor
index 505eb2231f..303eb0a13e 100644
--- a/basis/ui/gadgets/menus/menus-docs.factor
+++ b/basis/ui/gadgets/menus/menus-docs.factor
@@ -3,7 +3,7 @@ kernel ;
IN: ui.gadgets.menus
HELP: <commands-menu>
-{ $values { "hook" "a quotation with stack effect " { $snippet "( button -- )" } } { "target" object } { "commands" "a sequence of commands" } { "gadget" "a new " { $link gadget } } }
+{ $values { "hook" { $quotation "( button -- )" } } { "target" object } { "commands" "a sequence of commands" } { "gadget" "a new " { $link gadget } } }
{ $description "Creates a popup menu of commands which are to be invoked on " { $snippet "target" } ". The " { $snippet "hook" } " quotation is run before a command is invoked." } ;
HELP: show-menu
diff --git a/basis/ui/gadgets/panes/panes-docs.factor b/basis/ui/gadgets/panes/panes-docs.factor
index 99f8b2e82a..d53cba5f76 100644
--- a/basis/ui/gadgets/panes/panes-docs.factor
+++ b/basis/ui/gadgets/panes/panes-docs.factor
@@ -43,7 +43,7 @@ HELP: <scrolling-pane>
{ $description "Creates a new " { $link pane } " gadget which scrolls any scroll pane containing it to the bottom on output. behaving much like a terminal or logger." } ;
HELP: <pane-control>
-{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( value -- )" } } { "pane" "a new " { $link pane } } }
+{ $values { "model" model } { "quot" { $quotation "( value -- )" } } { "pane" "a new " { $link pane } } }
{ $description "Creates a new control delegating to a " { $link pane } ". When the value of the model changes, the value is pushed on the stack and the quotation is called using " { $link with-pane } "." } ;
HELP: pane-stream
diff --git a/basis/ui/operations/operations-docs.factor b/basis/ui/operations/operations-docs.factor
index 4ab17228b5..d05519f46a 100644
--- a/basis/ui/operations/operations-docs.factor
+++ b/basis/ui/operations/operations-docs.factor
@@ -49,7 +49,7 @@ HELP: secondary-operation
{ $description "Outputs the operation which should be invoked when a " { $snippet "RET" } " is pressed while a presentation of " { $snippet "obj" } " is selected in a list." } ;
HELP: define-operation
-{ $values { "pred" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "command" word } { "flags" hashtable } }
+{ $values { "pred" { $quotation "( obj -- ? )" } } { "command" word } { "flags" hashtable } }
{ $description "Defines an operation on objects matching the predicate. The hashtable can contain the following keys:"
{ $list
{ { $link +listener+ } " - if set to a true value, the operation will run in the listener" }
@@ -61,7 +61,7 @@ HELP: define-operation
} ;
HELP: define-operation-map
-{ $values { "class" "a class word" } { "group" string } { "blurb" { $maybe string } } { "object" object } { "hook" "a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } } { "translator" "a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } } }
+{ $values { "class" "a class word" } { "group" string } { "blurb" { $maybe string } } { "object" object } { "hook" { $quotation "( obj -- newobj )" } ", or " { $link f } } { "translator" { $quotation "( obj -- newobj )" } ", or " { $link f } } }
{ $description "Defines a command map named " { $snippet "group" } " on " { $snippet "class" } " consisting of operations applicable to " { $snippet "object" } ". The hook quotation is applied to the target gadget; the translator quotation is applied to the result of the hook. Finally the result of the translator is passed to the operation. A distinction is drawn between the hook and the translator because for listener operations, the hook runs in the event loop and the translator runs in the listener. This avoids polluting the listener output with large prettyprinted gadgets and long quotations." } ;
HELP: $operations
diff --git a/basis/ui/tools/debugger/debugger-docs.factor b/basis/ui/tools/debugger/debugger-docs.factor
index b57dafaf49..12a2e0d806 100644
--- a/basis/ui/tools/debugger/debugger-docs.factor
+++ b/basis/ui/tools/debugger/debugger-docs.factor
@@ -3,7 +3,7 @@ continuations debugger ui ;
IN: ui.tools.debugger
HELP: <debugger>
-{ $values { "error" "an error" } { "restarts" "a sequence of " { $link restart } " instances" } { "restart-hook" "a quotation with stack effect " { $snippet "( list -- )" } } { "gadget" "a new " { $link gadget } } }
+{ $values { "error" "an error" } { "restarts" "a sequence of " { $link restart } " instances" } { "restart-hook" { $quotation "( list -- )" } } { "gadget" "a new " { $link gadget } } }
{ $description
"Creates a gadget displaying a description of the error, along with buttons to print the contents of the stacks in the listener, and a list of restarts."
} ;
diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor
index 9dd3a712c0..58509fc2df 100644
--- a/basis/ui/ui-docs.factor
+++ b/basis/ui/ui-docs.factor
@@ -23,7 +23,7 @@ HELP: fullscreen?
{ fullscreen? set-fullscreen? } related-words
HELP: find-window
-{ $values { "quot" "a quotation with stack effect " { $snippet "( world -- ? )" } } { "world" { $maybe world } } }
+{ $values { "quot" { $quotation "( world -- ? )" } } { "world" { $maybe world } } }
{ $description "Finds a native window such that the gadget passed to " { $link open-window } " satisfies the quotation, outputting " { $link f } " if no such gadget could be found. The front-most native window is checked first." } ;
HELP: register-window
diff --git a/basis/values/values-docs.factor b/basis/values/values-docs.factor
index c96ea0f8cf..69e2801110 100644
--- a/basis/values/values-docs.factor
+++ b/basis/values/values-docs.factor
@@ -35,5 +35,5 @@ HELP: to:
} ;
HELP: change-value
-{ $values { "word" "a value word" } { "quot" "a quotation with stack effect " { $snippet "( oldvalue -- newvalue )" } } }
+{ $values { "word" "a value word" } { "quot" { $quotation "( oldvalue -- newvalue )" } } }
{ $description "Changes the value using the given quotation." } ;
diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor
index f969b208eb..b02e0189b2 100644
--- a/core/assocs/assocs-docs.factor
+++ b/core/assocs/assocs-docs.factor
@@ -161,7 +161,7 @@ HELP: new-assoc
{ $contract "Creates a new assoc of the same size as " { $snippet "exemplar" } " which can hold " { $snippet "capacity" } " entries before growing." } ;
HELP: assoc-find
-{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "key" "the successful key, or f" } { "value" "the successful value, or f" } { "?" "a boolean" } }
+{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "key" "the successful key, or f" } { "value" "the successful value, or f" } { "?" "a boolean" } }
{ $description "Applies a predicate quotation to each entry in the assoc. Returns the key and value that the quotation succeeds on, or " { $link f } " for both if the quotation fails. It also returns a boolean describing whether there was anything found; this can be used to distinguish between a key and a value equal to " { $link f } ", or nothing being found." } ;
HELP: clear-assoc
@@ -197,7 +197,7 @@ HELP: at
{ $description "Looks up the value associated with a key. This word makes no distinction between a missing value and a value set to " { $link f } "; if the difference is important, use " { $link at* } "." } ;
HELP: assoc-each
-{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- )" } } }
+{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- )" } } }
{ $description "Applies a quotation to each entry in the assoc." }
{ $examples
{ $example
@@ -209,7 +209,7 @@ HELP: assoc-each
} ;
HELP: assoc-map
-{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- newkey newvalue )" } } { "newassoc" "a new assoc" } }
+{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- newkey newvalue )" } } { "newassoc" "a new assoc" } }
{ $description "Applies the quotation to each entry in the input assoc and collects the results in a new assoc of the same type as the input." }
{ $examples
{ $unchecked-example
@@ -224,19 +224,19 @@ HELP: assoc-map
{ assoc-map assoc-map-as } related-words
HELP: assoc-push-if
-{ $values { "accum" "a resizable mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "key" object } { "value" object } }
+{ $values { "accum" "a resizable mutable sequence" } { "quot" { $quotation "( key value -- ? )" } } { "key" object } { "value" object } }
{ $description "If the quotation yields true when applied to the key/value pair, adds the key/value pair at the end of " { $snippet "accum" } "." } ;
HELP: assoc-filter
-{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "subassoc" "a new assoc" } }
+{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "subassoc" "a new assoc" } }
{ $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields true." } ;
HELP: assoc-contains?
-{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } }
+{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "?" "a boolean" } }
{ $description "Tests if the assoc contains an entry satisfying a predicate by applying the quotation to each entry in turn. Iteration stops if an entry is found for which the quotation outputs a true value." } ;
HELP: assoc-all?
-{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } }
+{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "?" "a boolean" } }
{ $description "Tests if all entries in the assoc satisfy a predicate by applying the quotation to each entry in turn. a predicate quotation to entry in the assoc. Iteration stops if an entry is found for which the quotation outputs " { $link f } ". If the assoc is empty, always outputs " { $link t } "." } ;
HELP: assoc-subset?
@@ -325,20 +325,20 @@ HELP: substitute
{ $description "Creates a new sequence where elements of " { $snippet "seq" } " which appear as keys in " { $snippet "assoc" } " are replaced by the corresponding values, and all other elements are unchanged." } ;
HELP: cache
-{ $values { "key" "a key" } { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key -- value )" } } { "value" "a previously-retained or freshly-computed value" } }
+{ $values { "key" "a key" } { "assoc" assoc } { "quot" { $quotation "( key -- value )" } } { "value" "a previously-retained or freshly-computed value" } }
{ $description "If the key is present in the assoc, outputs the associated value, otherwise calls the quotation to produce a value and stores the key/value pair into the assoc." }
{ $side-effects "assoc" } ;
HELP: map>assoc
-{ $values { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- key value )" } } { "exemplar" assoc } { "assoc" "a new assoc" } }
+{ $values { "seq" "a sequence" } { "quot" { $quotation "( elt -- key value )" } } { "exemplar" assoc } { "assoc" "a new assoc" } }
{ $description "Applies the quotation to each element of the sequence, and collects the keys and values into a new assoc having the same type as " { $snippet "exemplar" } "." } ;
HELP: assoc>map
-{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- elt )" } } { "exemplar" "a sequence" } { "seq" "a new sequence" } }
+{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- elt )" } } { "exemplar" "a sequence" } { "seq" "a new sequence" } }
{ $description "Applies the quotation to each entry of the assoc and collects the results into a new sequence of the same type as the exemplar." } ;
HELP: change-at
-{ $values { "key" object } { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( value -- newvalue )" } } }
+{ $values { "key" object } { "assoc" assoc } { "quot" { $quotation "( value -- newvalue )" } } }
{ $description "Applies the quotation to the value associated with " { $snippet "key" } ", storing the new value back in the assoc." }
{ $side-effects "assoc" } ;
diff --git a/core/classes/predicate/predicate-docs.factor b/core/classes/predicate/predicate-docs.factor
index d03d97cd4c..3ea0a24674 100644
--- a/core/classes/predicate/predicate-docs.factor
+++ b/core/classes/predicate/predicate-docs.factor
@@ -14,7 +14,7 @@ ARTICLE: "predicates" "Predicate classes"
ABOUT: "predicates"
HELP: define-predicate-class
-{ $values { "class" class } { "superclass" class } { "definition" "a quotation with stack effect " { $snippet "( superclass -- ? )" } } }
+{ $values { "class" class } { "superclass" class } { "definition" { $quotation "( superclass -- ? )" } } }
{ $description "Defines a predicate class. This is the run time equivalent of " { $link POSTPONE: PREDICATE: } "." }
{ $notes "This word must be called from inside " { $link with-compilation-unit } "." }
{ $side-effects "class" } ;
diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor
index a494c09b05..0caabf2fad 100644
--- a/core/combinators/combinators-docs.factor
+++ b/core/combinators/combinators-docs.factor
@@ -137,7 +137,7 @@ HELP: no-case
{ $error-description "Thrown by " { $link case } " if the object at the top of the stack does not match any case, and no default case is given." } ;
HELP: recursive-hashcode
-{ $values { "n" integer } { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( n obj -- code )" } } { "code" integer } }
+{ $values { "n" integer } { "obj" object } { "quot" { $quotation "( n obj -- code )" } } { "code" integer } }
{ $description "A combinator used to implement methods for the " { $link hashcode* } " generic word. If " { $snippet "n" } " is less than or equal to zero, outputs 0, otherwise calls the quotation." } ;
HELP: cond>quot
@@ -159,7 +159,7 @@ $nl
} } ;
HELP: distribute-buckets
-{ $values { "alist" "an alist" } { "initial" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- assoc )" } } { "buckets" "a new array" } }
+{ $values { "alist" "an alist" } { "initial" object } { "quot" { $quotation "( obj -- assoc )" } } { "buckets" "a new array" } }
{ $description "Sorts the entries of " { $snippet "assoc" } " into buckets, using the quotation to yield a set of keys for each entry. The hashcode of each key is computed, and the entry is placed in all corresponding buckets. Each bucket is initially cloned from " { $snippet "initial" } "; this should either be an empty vector or a one-element vector containing a pair." }
{ $notes "This word is used in the implemention of " { $link hash-case-quot } " and " { $link standard-combination } "." } ;
diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor
index f5ebc2a338..7a22306c50 100644
--- a/core/continuations/continuations-docs.factor
+++ b/core/continuations/continuations-docs.factor
@@ -108,17 +108,17 @@ HELP: >continuation<
{ $description "Takes a continuation apart into its constituents." } ;
HELP: ifcc
-{ $values { "capture" "a quotation with stack effect " { $snippet "( continuation -- )" } } { "restore" quotation } }
+{ $values { "capture" { $quotation "( continuation -- )" } } { "restore" quotation } }
{ $description "Reifies a continuation from the point immediately after which this word returns, and passes it to " { $snippet "capture" } ". When the continuation is restored, execution resumes and "{ $snippet "restore" } " is called." } ;
{ callcc0 continue callcc1 continue-with ifcc } related-words
HELP: callcc0
-{ $values { "quot" "a quotation with stack effect " { $snippet "( continuation -- )" } } }
+{ $values { "quot" { $quotation "( continuation -- )" } } }
{ $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue } " word resumes the continuation." } ;
HELP: callcc1
-{ $values { "quot" "a quotation with stack effect " { $snippet "( continuation -- )" } } { "obj" "an object provided when resuming the continuation" } }
+{ $values { "quot" { $quotation "( continuation -- )" } } { "obj" "an object provided when resuming the continuation" } }
{ $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue-with } " word resumes the continuation, passing a value back to the original execution context." } ;
HELP: continue
@@ -160,7 +160,7 @@ HELP: cleanup
{ $description "Calls the " { $snippet "try" } " quotation. If no error is thrown, calls " { $snippet "cleanup-always" } " without restoring the data stack. If an error is thrown, restores the data stack, calls " { $snippet "cleanup-always" } " followed by " { $snippet "cleanup-error" } ", and rethrows the error." } ;
HELP: recover
-{ $values { "try" quotation } { "recovery" "a quotation with stack effect " { $snippet "( error -- )" } } }
+{ $values { "try" quotation } { "recovery" { $quotation "( error -- )" } } }
{ $description "Calls the " { $snippet "try" } " quotation. If an exception is thrown in the dynamic extent of the " { $snippet "try" } " quotation, restores the data stack and calls the " { $snippet "recovery" } " quotation to handle the error." } ;
HELP: ignore-errors
diff --git a/core/destructors/destructors-docs.factor b/core/destructors/destructors-docs.factor
index c82f92dc10..0b6ca15f31 100644
--- a/core/destructors/destructors-docs.factor
+++ b/core/destructors/destructors-docs.factor
@@ -21,7 +21,7 @@ HELP: dispose*
} ;
HELP: with-disposal
-{ $values { "object" "a disposable object" } { "quot" "a quotation with stack effect " { $snippet "( object -- )" } } }
+{ $values { "object" "a disposable object" } { "quot" { $quotation "( object -- )" } } }
{ $description "Calls the quotation, disposing the object with " { $link dispose } " after the quotation returns or if it throws an error." } ;
HELP: with-destructors
diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor
index 182cfbf419..b5f22ec120 100644
--- a/core/generic/generic-docs.factor
+++ b/core/generic/generic-docs.factor
@@ -146,7 +146,7 @@ HELP: check-method
{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link create-method } " is given an invalid class or generic word." } ;
HELP: with-methods
-{ $values { "class" class } { "generic" generic } { "quot" "a quotation with stack effect " { $snippet "( methods -- )" } } }
+{ $values { "class" class } { "generic" generic } { "quot" { $quotation "( methods -- )" } } }
{ $description "Applies a quotation to the generic word's methods hashtable, and regenerates the generic word's definition when the quotation returns." }
$low-level-note ;
diff --git a/core/generic/math/math-docs.factor b/core/generic/math/math-docs.factor
index b0201f3248..da5d4f9eed 100644
--- a/core/generic/math/math-docs.factor
+++ b/core/generic/math/math-docs.factor
@@ -3,7 +3,7 @@ sequences quotations ;
IN: generic.math
HELP: math-upgrade
-{ $values { "class1" class } { "class2" class } { "quot" "a quotation with stack effect " { $snippet "( n n -- n n )" } } }
+{ $values { "class1" class } { "class2" class } { "quot" { $quotation "( n n -- n n )" } } }
{ $description "Outputs a quotation for upgrading numberical types. It takes two numbers on the stack, an instance of " { $snippet "class1" } ", and an instance of " { $snippet "class2" } ", and converts the one with the lower priority to the higher priority type." }
{ $examples { $example "USING: generic.math math kernel prettyprint ;" "fixnum bignum math-upgrade ." "[ [ >bignum ] dip ]" } } ;
diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor
index 71f3980a6c..289d39868c 100644
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@@ -170,7 +170,7 @@ HELP: xor
{ $notes "This word implements boolean exclusive or, so applying it to integers will not yield useful results (all integers have a true value). Bitwise exclusive or is the " { $link bitxor } " word." } ;
HELP: both?
-{ $values { "quot" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "x" object } { "y" object } { "?" "a boolean" } }
+{ $values { "quot" { $quotation "( obj -- ? )" } } { "x" object } { "y" object } { "?" "a boolean" } }
{ $description "Tests if the quotation yields a true value when applied to both " { $snippet "x" } " and " { $snippet "y" } "." }
{ $examples
{ $example "USING: kernel math prettyprint ;" "3 5 [ odd? ] both? ." "t" }
@@ -178,7 +178,7 @@ HELP: both?
} ;
HELP: either?
-{ $values { "quot" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "x" object } { "y" object } { "?" "a boolean" } }
+{ $values { "quot" { $quotation "( obj -- ? )" } } { "x" object } { "y" object } { "?" "a boolean" } }
{ $description "Tests if the quotation yields a true value when applied to either " { $snippet "x" } " or " { $snippet "y" } "." }
{ $examples
{ $example "USING: kernel math prettyprint ;" "3 6 [ odd? ] either? ." "t" }
@@ -211,19 +211,19 @@ HELP: 3slip
{ $description "Calls a quotation while hiding the top three stack elements." } ;
HELP: keep
-{ $values { "quot" "a quotation with stack effect " { $snippet "( x -- )" } } { "x" object } }
+{ $values { "quot" { $quotation "( x -- )" } } { "x" object } }
{ $description "Call a quotation with a value on the stack, restoring the value when the quotation returns." } ;
HELP: 2keep
-{ $values { "quot" "a quotation with stack effect " { $snippet "( x y -- )" } } { "x" object } { "y" object } }
+{ $values { "quot" { $quotation "( x y -- )" } } { "x" object } { "y" object } }
{ $description "Call a quotation with two values on the stack, restoring the values when the quotation returns." } ;
HELP: 3keep
-{ $values { "quot" "a quotation with stack effect " { $snippet "( x y z -- )" } } { "x" object } { "y" object } { "z" object } }
+{ $values { "quot" { $quotation "( x y z -- )" } } { "x" object } { "y" object } { "z" object } }
{ $description "Call a quotation with three values on the stack, restoring the values when the quotation returns." } ;
HELP: bi
-{ $values { "x" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x -- ... )" } } }
+{ $values { "x" object } { "p" { $quotation "( x -- ... )" } } { "q" { $quotation "( x -- ... )" } } }
{ $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "x" } "." }
{ $examples
"If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x -- )" } ", then the following two lines are equivalent:"
@@ -245,7 +245,7 @@ HELP: bi
} ;
HELP: 2bi
-{ $values { "x" object } { "y" object } { "p" "a quotation with stack effect " { $snippet "( x y -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y -- ... )" } } }
+{ $values { "x" object } { "y" object } { "p" { $quotation "( x y -- ... )" } } { "q" { $quotation "( x y -- ... )" } } }
{ $description "Applies " { $snippet "p" } " to the two input values, then applies " { $snippet "q" } " to the two input values." }
{ $examples
"If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y -- )" } ", then the following two lines are equivalent:"
@@ -266,7 +266,7 @@ HELP: 2bi
} ;
HELP: 3bi
-{ $values { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } }
+{ $values { "x" object } { "y" object } { "z" object } { "p" { $quotation "( x y z -- ... )" } } { "q" { $quotation "( x y z -- ... )" } } }
{ $description "Applies " { $snippet "p" } " to the three input values, then applies " { $snippet "q" } " to the three input values." }
{ $examples
"If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y z -- )" } ", then the following two lines are equivalent:"
@@ -287,7 +287,7 @@ HELP: 3bi
} ;
HELP: tri
-{ $values { "x" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "r" "a quotation with stack effect " { $snippet "( x -- ... )" } } }
+{ $values { "x" object } { "p" { $quotation "( x -- ... )" } } { "q" { $quotation "( x -- ... )" } } { "r" { $quotation "( x -- ... )" } } }
{ $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "x" } ", and finally applies " { $snippet "r" } " to " { $snippet "x" } "." }
{ $examples
"If " { $snippet "[ p ]" } ", " { $snippet "[ q ]" } " and " { $snippet "[ r ]" } " have stack effect " { $snippet "( x -- )" } ", then the following two lines are equivalent:"
@@ -308,7 +308,7 @@ HELP: tri
} ;
HELP: 2tri
-{ $values { "x" object } { "y" object } { "p" "a quotation with stack effect " { $snippet "( x y -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y -- ... )" } } { "r" "a quotation with stack effect " { $snippet "( x y -- ... )" } } }
+{ $values { "x" object } { "y" object } { "p" { $quotation "( x y -- ... )" } } { "q" { $quotation "( x y -- ... )" } } { "r" { $quotation "( x y -- ... )" } } }
{ $description "Applies " { $snippet "p" } " to the two input values, then applies " { $snippet "q" } " to the two input values, and finally applies " { $snippet "r" } " to the two input values." }
{ $examples
"If " { $snippet "[ p ]" } ", " { $snippet "[ q ]" } " and " { $snippet "[ r ]" } " have stack effect " { $snippet "( x y -- )" } ", then the following two lines are equivalent:"
@@ -324,7 +324,7 @@ HELP: 2tri
} ;
HELP: 3tri
-{ $values { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "r" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } }
+{ $values { "x" object } { "y" object } { "z" object } { "p" { $quotation "( x y z -- ... )" } } { "q" { $quotation "( x y z -- ... )" } } { "r" { $quotation "( x y z -- ... )" } } }
{ $description "Applies " { $snippet "p" } " to the three input values, then applies " { $snippet "q" } " to the three input values, and finally applies " { $snippet "r" } " to the three input values." }
{ $examples
"If " { $snippet "[ p ]" } ", " { $snippet "[ q ]" } " and " { $snippet "[ r ]" } " have stack effect " { $snippet "( x y z -- )" } ", then the following two lines are equivalent:"
@@ -341,7 +341,7 @@ HELP: 3tri
HELP: bi*
-{ $values { "x" object } { "y" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( y -- ... )" } } }
+{ $values { "x" object } { "y" object } { "p" { $quotation "( x -- ... )" } } { "q" { $quotation "( y -- ... )" } } }
{ $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "y" } "." }
{ $examples
"The following two lines are equivalent:"
@@ -352,7 +352,7 @@ HELP: bi*
} ;
HELP: 2bi*
-{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( w x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( y z -- ... )" } } }
+{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "p" { $quotation "( w x -- ... )" } } { "q" { $quotation "( y z -- ... )" } } }
{ $description "Applies " { $snippet "p" } " to " { $snippet "w" } " and " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "y" } " and " { $snippet "z" } "." }
{ $examples
"The following two lines are equivalent:"
@@ -363,7 +363,7 @@ HELP: 2bi*
} ;
HELP: tri*
-{ $values { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( y -- ... )" } } { "r" "a quotation with stack effect " { $snippet "( z -- ... )" } } }
+{ $values { "x" object } { "y" object } { "z" object } { "p" { $quotation "( x -- ... )" } } { "q" { $quotation "( y -- ... )" } } { "r" { $quotation "( z -- ... )" } } }
{ $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "y" } ", and finally applies " { $snippet "r" } " to " { $snippet "z" } "." }
{ $examples
"The following two lines are equivalent:"
@@ -374,7 +374,7 @@ HELP: tri*
} ;
HELP: bi@
-{ $values { "x" object } { "y" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } }
+{ $values { "x" object } { "y" object } { "quot" { $quotation "( obj -- )" } } }
{ $description "Applies the quotation to " { $snippet "x" } ", then to " { $snippet "y" } "." }
{ $examples
"The following two lines are equivalent:"
@@ -390,7 +390,7 @@ HELP: bi@
} ;
HELP: 2bi@
-{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "quot" "a quotation with stack effect " { $snippet "( obj1 obj2 -- )" } } }
+{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "quot" { $quotation "( obj1 obj2 -- )" } } }
{ $description "Applies the quotation to " { $snippet "w" } " and " { $snippet "x" } ", then to " { $snippet "y" } " and " { $snippet "z" } "." }
{ $examples
"The following two lines are equivalent:"
@@ -406,7 +406,7 @@ HELP: 2bi@
} ;
HELP: tri@
-{ $values { "x" object } { "y" object } { "z" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } }
+{ $values { "x" object } { "y" object } { "z" object } { "quot" { $quotation "( obj -- )" } } }
{ $description "Applies the quotation to " { $snippet "x" } ", then to " { $snippet "y" } ", and finally to " { $snippet "z" } "." }
{ $examples
"The following two lines are equivalent:"
@@ -440,7 +440,7 @@ $nl
"The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ;
HELP: if*
-{ $values { "?" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" quotation } }
+{ $values { "?" "a generalized boolean" } { "true" { $quotation "( cond -- )" } } { "false" quotation } }
{ $description "Alternative conditional form that preserves the " { $snippet "cond" } " value if it is true."
$nl
"If the condition is true, it is retained on the stack before the " { $snippet "true" } " quotation is called. Otherwise, the condition is removed from the stack and the " { $snippet "false" } " quotation is called."
@@ -449,7 +449,7 @@ $nl
{ $code "X [ Y ] [ Z ] if*" "X dup [ Y ] [ drop Z ] if" } } ;
HELP: when*
-{ $values { "?" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } }
+{ $values { "?" "a generalized boolean" } { "true" { $quotation "( cond -- )" } } }
{ $description "Variant of " { $link if* } " with no false quotation."
$nl
"The following two lines are equivalent:"
@@ -463,7 +463,7 @@ HELP: unless*
{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" } } ;
HELP: ?if
-{ $values { "default" object } { "cond" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" "a quotation with stack effect " { $snippet "( default -- )" } } }
+{ $values { "default" object } { "cond" "a generalized boolean" } { "true" { $quotation "( cond -- )" } } { "false" { $quotation "( default -- )" } } }
{ $description "If the condition is " { $link f } ", the " { $snippet "false" } " quotation is called with the " { $snippet "default" } " value on the stack. Otherwise, the " { $snippet "true" } " quotation is called with the condition on the stack." }
{ $notes
"The following two lines are equivalent:"
@@ -520,7 +520,7 @@ HELP: null
} ;
HELP: most
-{ $values { "x" object } { "y" object } { "quot" "a quotation with stack effect " { $snippet "( x y -- ? )" } } { "z" "either " { $snippet "x" } " or " { $snippet "y" } } }
+{ $values { "x" object } { "y" object } { "quot" { $quotation "( x y -- ? )" } } { "z" "either " { $snippet "x" } " or " { $snippet "y" } } }
{ $description "If the quotation yields a true value when applied to " { $snippet "x" } " and " { $snippet "y" } ", outputs " { $snippet "x" } ", otherwise outputs " { $snippet "y" } "." } ;
HELP: curry
@@ -550,7 +550,7 @@ HELP: 3curry
{ $notes "This operation is efficient and does not copy the quotation." } ;
HELP: with
-{ $values { "param" object } { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( param elt -- ... )" } } { "obj" object } { "curry" curry } }
+{ $values { "param" object } { "obj" object } { "quot" { $quotation "( param elt -- ... )" } } { "obj" object } { "curry" curry } }
{ $description "Partial application on the left. The following two lines are equivalent:"
{ $code "swap [ swap A ] curry B" }
{ $code "[ A ] with B" }
@@ -630,7 +630,7 @@ HELP: 3dip
} ;
HELP: while
-{ $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } }
+{ $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } }
{ $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "body" } " is called. After iteration stops, " { $snippet "tail" } " is called." }
{ $notes "In most cases, tail recursion should be used, because it is simpler both in terms of implementation and conceptually. However in some cases this combinator expresses intent better and should be used."
$nl
diff --git a/core/lexer/lexer-docs.factor b/core/lexer/lexer-docs.factor
index ead3c15a37..31f5a3f72e 100644
--- a/core/lexer/lexer-docs.factor
+++ b/core/lexer/lexer-docs.factor
@@ -32,7 +32,7 @@ HELP: skip
{ $description "Skips to the first space character (if " { $snippet "boolean" } " is " { $link f } ") or the first non-space character (otherwise)." } ;
HELP: change-lexer-column
-{ $values { "lexer" lexer } { "quot" "a quotation with stack effect " { $snippet "( col line -- newcol )" } } }
+{ $values { "lexer" lexer } { "quot" { $quotation "( col line -- newcol )" } } }
{ $description "Applies a quotation to the current column and line text to produce a new column, and moves the lexer position." } ;
HELP: skip-blank
diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor
index a863715d33..20b4e0bbbe 100644
--- a/core/math/math-docs.factor
+++ b/core/math/math-docs.factor
@@ -284,22 +284,22 @@ HELP: power-of-2?
{ $description "Tests if " { $snippet "n" } " is a power of 2." } ;
HELP: each-integer
-{ $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( i -- )" } } }
+{ $values { "n" integer } { "quot" { $quotation "( i -- )" } } }
{ $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } "." }
{ $notes "This word is used to implement " { $link each } "." } ;
HELP: all-integers?
-{ $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( i -- ? )" } } { "?" "a boolean" } }
+{ $values { "n" integer } { "quot" { $quotation "( i -- ? )" } } { "?" "a boolean" } }
{ $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } ". Iterationi stops when the quotation outputs " { $link f } " or the end is reached. If the quotation yields a false value for some integer, this word outputs " { $link f } ". Otherwise, this word outputs " { $link t } "." }
{ $notes "This word is used to implement " { $link all? } "." } ;
HELP: find-integer
-{ $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( i -- ? )" } } { "i" "an integer or " { $link f } } }
+{ $values { "n" integer } { "quot" { $quotation "( i -- ? )" } } { "i" "an integer or " { $link f } } }
{ $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } ". Iterationi stops when the quotation outputs a true value or the end is reached. If the quotation yields a true value for some integer, this word outputs that integer. Otherwise, this word outputs " { $link f } "." }
{ $notes "This word is used to implement " { $link find } "." } ;
HELP: find-last-integer
-{ $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( i -- ? )" } } { "i" "an integer or " { $link f } } }
+{ $values { "n" integer } { "quot" { $quotation "( i -- ? )" } } { "i" "an integer or " { $link f } } }
{ $description "Applies the quotation to each integer from " { $snippet "n" } " down to 0, inclusive. Iteration stops when the quotation outputs a true value or 0 is reached. If the quotation yields a true value for some integer, the word outputs that integer. Otherwise, the word outputs " { $link f } "." }
{ $notes "This word is used to implement " { $link find-last } "." } ;
diff --git a/core/math/order/order-docs.factor b/core/math/order/order-docs.factor
index 65edbdaaae..c8d3095ce6 100644
--- a/core/math/order/order-docs.factor
+++ b/core/math/order/order-docs.factor
@@ -32,7 +32,7 @@ HELP: invert-comparison
{ $example "USING: math.order prettyprint ;" "+lt+ invert-comparison ." "+gt+" } } ;
HELP: compare
-{ $values { "obj1" object } { "obj2" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "<=>" "an ordering specifier" } }
+{ $values { "obj1" object } { "obj2" object } { "quot" { $quotation "( obj -- newobj )" } } { "<=>" "an ordering specifier" } }
{ $description "Compares the results of applying the quotation to both objects via " { $link <=> } "." }
{ $examples { $example "USING: kernel math.order prettyprint sequences ;" "\"hello\" \"hi\" [ length ] compare ." "+gt+" }
} ;
diff --git a/core/memory/memory-docs.factor b/core/memory/memory-docs.factor
index fb1d4a336f..8f49d882ee 100644
--- a/core/memory/memory-docs.factor
+++ b/core/memory/memory-docs.factor
@@ -19,12 +19,12 @@ HELP: end-scan ( -- )
{ $notes "This is a low-level facility and can be dangerous. Use the " { $link each-object } " combinator instead." } ;
HELP: each-object
-{ $values { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } }
+{ $values { "quot" { $quotation "( obj -- )" } } }
{ $description "Applies a quotation to each object in the heap. The garbage collector is switched off while this combinator runs, so the given quotation must not allocate too much memory." }
{ $notes "This word is the low-level facility used to implement the " { $link instances } " word." } ;
HELP: instances
-{ $values { "quot" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "seq" "a fresh sequence" } }
+{ $values { "quot" { $quotation "( obj -- ? )" } } { "seq" "a fresh sequence" } }
{ $description "Outputs a sequence of all objects in the heap which satisfy the quotation." }
{ $notes "This word relies on " { $link each-object } ", so in particular the garbage collector is switched off while it runs and the given quotation must not allocate too much memory." } ;
diff --git a/core/namespaces/namespaces-docs.factor b/core/namespaces/namespaces-docs.factor
index c84699539d..4716a8fe99 100644
--- a/core/namespaces/namespaces-docs.factor
+++ b/core/namespaces/namespaces-docs.factor
@@ -69,7 +69,7 @@ HELP: on
{ $side-effects "variable" } ;
HELP: change
-{ $values { "variable" "a variable, by convention a symbol" } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } }
+{ $values { "variable" "a variable, by convention a symbol" } { "quot" { $quotation "( old -- new )" } } }
{ $description "Applies the quotation to the old value of the variable, and assigns the resulting value to the variable." }
{ $side-effects "variable" } ;
diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor
index d33f5cd6d9..d3c2cff19d 100644
--- a/core/parser/parser-docs.factor
+++ b/core/parser/parser-docs.factor
@@ -294,7 +294,7 @@ HELP: parse-base
$parsing-note ;
HELP: parse-literal
-{ $values { "accum" vector } { "end" word } { "quot" "a quotation with stack effect " { $snippet "( seq -- obj )" } } }
+{ $values { "accum" vector } { "end" word } { "quot" { $quotation "( seq -- obj )" } } }
{ $description "Parses objects from parser input until " { $snippet "end" } ", applies the quotation to the resulting sequence, and adds the output value to the accumulator." }
{ $examples "This word is used to implement " { $link POSTPONE: [ } "." }
$parsing-note ;
diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor
index 8cb7f1c088..2789fc36c1 100644
--- a/core/sequences/sequences-docs.factor
+++ b/core/sequences/sequences-docs.factor
@@ -247,15 +247,15 @@ HELP: set-array-nth
{ $warning "This word is in the " { $vocab-link "sequences.private" } " vocabulary because it is unsafe. It does not check types or array bounds, and improper use can corrupt memory." } ;
HELP: collect
-{ $values { "n" "a non-negative integer" } { "quot" "a quotation with stack effect " { $snippet "( n -- value )" } } { "into" "a sequence of length at least " { $snippet "n" } } }
+{ $values { "n" "a non-negative integer" } { "quot" { $quotation "( n -- value )" } } { "into" "a sequence of length at least " { $snippet "n" } } }
{ $description "A primitive mapping operation that applies a quotation to all integers from 0 up to but not including " { $snippet "n" } ", and collects the results in a new array. User code should use " { $link map } " instead." } ;
HELP: each
-{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }
+{ $values { "seq" sequence } { "quot" { $quotation "( elt -- )" } } }
{ $description "Applies the quotation to each element of the sequence in order." } ;
HELP: reduce
-{ $values { "seq" sequence } { "identity" object } { "quot" "a quotation with stack effect " { $snippet "( prev elt -- next )" } } { "result" "the final result" } }
+{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt -- next )" } } { "result" "the final result" } }
{ $description "Combines successive elements of the sequence using a binary operation, and outputs the final result. On the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the sequence." }
{ $examples
{ $example "USING: math prettyprint sequences ;" "{ 1 5 3 } 0 [ + ] reduce ." "9" }
@@ -271,7 +271,7 @@ HELP: reduce-index
} } ;
HELP: accumulate
-{ $values { "identity" object } { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( prev elt -- next )" } } { "final" "the final result" } { "newseq" "a new sequence" } }
+{ $values { "identity" object } { "seq" sequence } { "quot" { $quotation "( prev elt -- next )" } } { "final" "the final result" } { "newseq" "a new sequence" } }
{ $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of intermediate results together with the final result. On the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the sequence."
$nl
"When given the empty sequence, outputs an empty sequence together with the " { $snippet "identity" } "." }
@@ -280,11 +280,11 @@ $nl
} ;
HELP: map
-{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } { "newseq" "a new sequence" } }
+{ $values { "seq" sequence } { "quot" { $quotation "( old -- new )" } } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as the input sequence." } ;
HELP: map-as
-{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } { "newseq" "a new sequence" } { "exemplar" sequence } }
+{ $values { "seq" sequence } { "quot" { $quotation "( old -- new )" } } { "newseq" "a new sequence" } { "exemplar" sequence } }
{ $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as " { $snippet "exemplar" } "." }
{ $examples
"The following example converts a string into an array of one-element strings:"
@@ -311,13 +311,13 @@ HELP: map-index
} } ;
HELP: change-nth
-{ $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } }
+{ $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" { $quotation "( elt -- newelt )" } } }
{ $description "Applies the quotation to the " { $snippet "i" } "th element of the sequence, storing the result back into the sequence." }
{ $errors "Throws an error if the sequence is immutable, if the index is out of bounds, or the sequence cannot hold elements of the type output by " { $snippet "quot" } "." }
{ $side-effects "seq" } ;
HELP: change-each
-{ $values { "seq" "a mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } }
+{ $values { "seq" "a mutable sequence" } { "quot" { $quotation "( old -- new )" } } }
{ $description "Applies the quotation to each element yielding a new element, storing the new elements back in the original sequence." }
{ $errors "Throws an error if the sequence is immutable, or the sequence cannot hold elements of the type output by " { $snippet "quot" } "." }
{ $side-effects "seq" } ;
@@ -331,7 +331,7 @@ HELP: max-length
{ $description "Outputs the maximum of the lengths of the two sequences." } ;
HELP: 2each
-{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- )" } } }
+{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- )" } } }
{ $description "Applies the quotation to pairs of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ;
HELP: 2reduce
@@ -344,15 +344,15 @@ HELP: 2reduce
{ $description "Combines successive pairs of elements from the two sequences using a ternary operation. The first input value at each iteration except the first one is the result of the previous iteration. The first input value at the first iteration is " { $snippet "identity" } "." } ;
HELP: 2map
-{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- new )" } } { "newseq" "a new sequence" } }
+{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- new )" } } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "seq1" } "." } ;
HELP: 2map-as
-{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } }
+{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "exemplar" } "." } ;
HELP: 2all?
-{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- ? )" } } { "?" "a boolean" } }
+{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- ? )" } } { "?" "a boolean" } }
{ $description "Tests the predicate pairwise against elements of " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ;
HELP: find
@@ -373,37 +373,37 @@ HELP: find-from
{ $description "Applies the quotation to each element of the sequence in turn, until it outputs a true value or the end of the sequence is reached. If the quotation yields a true value for some sequence element, the word outputs the element index and the element itself. Otherwise, the word outputs an index of f and " { $link f } " as the element." } ;
HELP: find-last
-{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } }
+{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } }
{ $description "A simpler variant of " { $link find-last-from } " where the starting index is one less than the length of the sequence." } ;
HELP: find-last-from
-{ $values { "n" "a starting index" } { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } }
+{ $values { "n" "a starting index" } { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } }
{ $description "Applies the quotation to each element of the sequence in reverse order, until it outputs a true value or the start of the sequence is reached. If the quotation yields a true value for some sequence element, the word outputs the element index and the element itself. Otherwise, the word outputs an index of f and " { $link f } " as the element." } ;
HELP: contains?
-{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "?" "a boolean" } }
+{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "?" "a boolean" } }
{ $description "Tests if the sequence contains an element satisfying the predicate, by applying the predicate to each element in turn until a true value is found. If the sequence is empty or if the end of the sequence is reached, outputs " { $link f } "." } ;
HELP: all?
-{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "?" "a boolean" } }
+{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "?" "a boolean" } }
{ $description "Tests if all elements in the sequence satisfy the predicate by checking each element in turn. Given an empty sequence, vacuously outputs " { $link t } "." } ;
HELP: push-if
-{ $values { "elt" object } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "accum" "a resizable mutable sequence" } }
+{ $values { "elt" object } { "quot" { $quotation "( elt -- ? )" } } { "accum" "a resizable mutable sequence" } }
{ $description "Adds the element at the end of the sequence if the quotation yields a true value." }
{ $notes "This word is a factor of " { $link filter } "." } ;
HELP: filter
-{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "subseq" "a new sequence" } }
+{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "subseq" "a new sequence" } }
{ $description "Applies the quotation to each element in turn, and outputs a new sequence containing the elements of the original sequence for which the quotation output a true value." } ;
HELP: filter-here
-{ $values { "seq" "a resizable mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } }
+{ $values { "seq" "a resizable mutable sequence" } { "quot" { $quotation "( elt -- ? )" } } }
{ $description "Applies the quotation to each element in turn, and removes elements for which the quotation outputs a false value." }
{ $side-effects "seq" } ;
HELP: monotonic?
-{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt elt -- ? )" } } { "?" "a boolean" } }
+{ $values { "seq" sequence } { "quot" { $quotation "( elt elt -- ? )" } } { "?" "a boolean" } }
{ $description "Applies the relation to successive pairs of elements in the sequence, testing for a truth value. The relation should be a transitive relation, such as a total order or an equality relation." }
{ $examples
"Testing if a sequence is non-decreasing:"
@@ -415,12 +415,12 @@ HELP: monotonic?
{ monotonic? all-eq? all-equal? } related-words
HELP: interleave
-{ $values { "seq" sequence } { "between" "a quotation" } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }
+{ $values { "seq" sequence } { "between" "a quotation" } { "quot" { $quotation "( elt -- )" } } }
{ $description "Applies " { $snippet "quot" } " to each element in turn, also invoking " { $snippet "between" } " in-between each pair of elements." }
{ $example "USING: io sequences ;" "{ \"a\" \"b\" \"c\" } [ \"X\" write ] [ write ] interleave" "aXbXc" } ;
HELP: cache-nth
-{ $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( i -- elt )" } } { "elt" object } }
+{ $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" { $quotation "( i -- elt )" } } { "elt" object } }
{ $description "If the sequence does not contain at least " { $snippet "i" } " elements or if the " { $snippet "i" } "th element of the sequence is " { $link f } ", calls the quotation to produce a new value, and stores it back into the sequence. Otherwise, this word outputs the " { $snippet "i" } "th element of the sequence." }
{ $side-effects "seq" } ;
@@ -584,7 +584,7 @@ HELP: reverse-here
{ $side-effects "seq" } ;
HELP: padding
-{ $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "quot" "a quotation with stack effect " { $snippet "( seq1 seq2 -- newseq )" } } { "newseq" "a new sequence" } }
+{ $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "quot" { $quotation "( seq1 seq2 -- newseq )" } } { "newseq" "a new sequence" } }
{ $description "Outputs a new string sequence of " { $snippet "elt" } " repeated, that when appended to " { $snippet "seq" } ", yields a sequence of length " { $snippet "n" } ". If the length of " { $snippet "seq" } " is greater than " { $snippet "n" } ", this word outputs an empty sequence." } ;
HELP: pad-left
@@ -874,7 +874,7 @@ HELP: supremum
{ $errors "Throws an error if the sequence is empty." } ;
HELP: produce
-{ $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "quot" "a quotation with stack effect " { $snippet "( -- obj )" } } { "tail" "a quotation" } { "seq" "a sequence" } }
+{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj )" } } { "tail" "a quotation" } { "seq" "a sequence" } }
{ $description "Calls " { $snippet "pred" } " repeatedly. If the predicate yields " { $link f } ", stops, otherwise, calls " { $snippet "quot" } " to yield a value. Values are accumulated and returned in a sequence at the end." }
{ $examples
"The following example divides a number by two until we reach zero, and accumulates intermediate results:"
diff --git a/core/sorting/sorting-docs.factor b/core/sorting/sorting-docs.factor
index 036ff2f759..6ea1485425 100644
--- a/core/sorting/sorting-docs.factor
+++ b/core/sorting/sorting-docs.factor
@@ -19,7 +19,7 @@ $nl
ABOUT: "sequences-sorting"
HELP: sort
-{ $values { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( obj1 obj2 -- <=> )" } } { "sortedseq" "a new sorted sequence" } }
+{ $values { "seq" "a sequence" } { "quot" { $quotation "( obj1 obj2 -- <=> )" } } { "sortedseq" "a new sorted sequence" } }
{ $description "Sorts the elements into a new array." } ;
HELP: sort-keys
diff --git a/core/vocabs/vocabs-docs.factor b/core/vocabs/vocabs-docs.factor
index 328dce9b03..64a5a589dc 100644
--- a/core/vocabs/vocabs-docs.factor
+++ b/core/vocabs/vocabs-docs.factor
@@ -75,7 +75,7 @@ HELP: forget-vocab
{ $notes "This word must be called from inside " { $link with-compilation-unit } "." } ;
HELP: load-vocab-hook
-{ $var-description "a quotation with stack effect " { $snippet "( name -- vocab )" } " which loads a vocabulary. This quotation is called by " { $link load-vocab } ". The default value should not need to be changed; this functinality is implemented via a hook stored in a variable to break a circular dependency which would otherwise exist from " { $vocab-link "vocabs" } " to " { $vocab-link "vocabs.loader" } " to " { $vocab-link "parser" } " back to " { $vocab-link "vocabs" } "." } ;
+{ $var-description { $quotation "( name -- vocab )" } " which loads a vocabulary. This quotation is called by " { $link load-vocab } ". The default value should not need to be changed; this functinality is implemented via a hook stored in a variable to break a circular dependency which would otherwise exist from " { $vocab-link "vocabs" } " to " { $vocab-link "vocabs.loader" } " to " { $vocab-link "parser" } " back to " { $vocab-link "vocabs" } "." } ;
HELP: words-named
{ $values { "str" string } { "seq" "a sequence of words" } }
diff --git a/extra/partial-continuations/partial-continuations-docs.factor b/extra/partial-continuations/partial-continuations-docs.factor
index 93e68eac4a..a70109347b 100644
--- a/extra/partial-continuations/partial-continuations-docs.factor
+++ b/extra/partial-continuations/partial-continuations-docs.factor
@@ -2,12 +2,12 @@ IN: partial-continuations
USING: help.markup help.syntax kernel ;
HELP: breset
-{ $values { "quot" "a quotation with stack effect " { $snippet "( r -- v )" } } }
+{ $values { "quot" { $quotation "( r -- v )" } } }
{ $description "Marks the boundary of the partial continuation. The quotation has stack effect " { $snippet "( r -- v )" } ", where " { $snippet "r" } " identifies the " { $link breset } " in scope and should be passed to "{ $link bshift } " to mark the boundary of the continuation." }
{ $notes "It is important to note that even if the quotation discards items on the stack, the stack will be restored to the way it was before it is called (which is true of continuation usage in general)." } ;
HELP: bshift
-{ $values { "r" "the " { $link breset } " in scope" } { "quot" "a quotation with stack effect " { $snippet "( pcc -- v )" } } }
+{ $values { "r" "the " { $link breset } " in scope" } { "quot" { $quotation "( pcc -- v )" } } }
{ $description "Calls the quotation with the partial continuation on the stack. The quotation should have stack effect " { $snippet "( pcc -- v )" } ". The partial continuation can be called with " { $link call } " and has stack effect " { $snippet "( a -- b )" } "." }
{ $notes "It is important to note that even if the quotation discards items on the stack, the stack will be restored to the way it was before it is called (which is true of continuation usage in general)." } ;
From acc1dc23fa9a2a117579def9486ce1ab9fdc7152 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 09:08:38 -0600
Subject: [PATCH 120/157] More usages of $quotation
---
basis/peg/peg-docs.factor | 4 ++--
.../tools/annotations/annotations-docs.factor | 2 +-
core/sequences/sequences-docs.factor | 13 ++++------
extra/lists/lazy/lazy-docs.factor | 24 +++++++++----------
extra/lists/lists-docs.factor | 12 +++++-----
extra/promises/promises-docs.factor | 6 ++---
6 files changed, 29 insertions(+), 32 deletions(-)
diff --git a/basis/peg/peg-docs.factor b/basis/peg/peg-docs.factor
index 00390c1b1e..976c32d102 100644
--- a/basis/peg/peg-docs.factor
+++ b/basis/peg/peg-docs.factor
@@ -98,7 +98,7 @@ HELP: optional
HELP: semantic
{ $values
{ "parser" "a parser" }
- { "quot" "a quotation with stack effect ( object -- bool )" }
+ { "quot" { $quotation "( object -- ? )" } }
}
{ $description
"Returns a parser that succeeds if the 'p1' parser succeeds and the quotation called with "
@@ -130,7 +130,7 @@ HELP: ensure-not
HELP: action
{ $values
{ "parser" "a parser" }
- { "quot" "a quotation with stack effect ( ast -- ast )" }
+ { "quot" { $quotation "( ast -- ast )" } }
}
{ $description
"Returns a parser that calls the 'p1' parser and applies the quotation to the AST resulting "
diff --git a/basis/tools/annotations/annotations-docs.factor b/basis/tools/annotations/annotations-docs.factor
index 41808d2f6a..c61b4547a9 100644
--- a/basis/tools/annotations/annotations-docs.factor
+++ b/basis/tools/annotations/annotations-docs.factor
@@ -28,7 +28,7 @@ HELP: breakpoint
{ $description "Annotates a word definition to enter the single stepper when executed." } ;
HELP: breakpoint-if
-{ $values { "quot" "a quotation with stack effect" { $snippet "( -- ? )" } } { "word" word } }
+{ $values { "quot" { $quotation "( -- ? )" } } { "word" word } }
{ $description "Annotates a word definition to enter the single stepper if the quotation yields true." } ;
HELP: annotate-methods
diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor
index 2789fc36c1..cc8daba8c0 100644
--- a/core/sequences/sequences-docs.factor
+++ b/core/sequences/sequences-docs.factor
@@ -338,8 +338,7 @@ HELP: 2reduce
{ $values { "seq1" sequence }
{ "seq2" sequence }
{ "identity" object }
- { "quot" "a quotation with stack effect "
- { $snippet "( prev elt1 elt2 -- next )" } }
+ { "quot" { $quotation "( prev elt1 elt2 -- next )" } }
{ "result" "the final result" } }
{ $description "Combines successive pairs of elements from the two sequences using a ternary operation. The first input value at each iteration except the first one is the result of the previous iteration. The first input value at the first iteration is " { $snippet "identity" } "." } ;
@@ -357,18 +356,16 @@ HELP: 2all?
HELP: find
{ $values { "seq" sequence }
- { "quot" "a quotation with stack effect "
- { $snippet "( elt -- ? )" } }
- { "i" "the index of the first match, or f" }
+ { "quot" { $quotation "( elt -- ? )" } }
+ { "i" "the index of the first match, or " { $link f } }
{ "elt" "the first matching element, or " { $link f } } }
{ $description "A simpler variant of " { $link find-from } " where the starting index is 0." } ;
HELP: find-from
{ $values { "n" "a starting index" }
{ "seq" sequence }
- { "quot" "a quotation with stack effect "
- { $snippet "( elt -- ? )" } }
- { "i" "the index of the first match, or f" }
+ { "quot" { $quotation "( elt -- ? )" } }
+ { "i" "the index of the first match, or " { $link f } }
{ "elt" "the first matching element, or " { $link f } } }
{ $description "Applies the quotation to each element of the sequence in turn, until it outputs a true value or the end of the sequence is reached. If the quotation yields a true value for some sequence element, the word outputs the element index and the element itself. Otherwise, the word outputs an index of f and " { $link f } " as the element." } ;
diff --git a/extra/lists/lazy/lazy-docs.factor b/extra/lists/lazy/lazy-docs.factor
index 6a9359027d..c402cdf15b 100644
--- a/extra/lists/lazy/lazy-docs.factor
+++ b/extra/lists/lazy/lazy-docs.factor
@@ -5,22 +5,22 @@ USING: help.markup help.syntax sequences strings lists ;
IN: lists.lazy
HELP: lazy-cons
-{ $values { "car" "a quotation with stack effect ( -- X )" } { "cdr" "a quotation with stack effect ( -- cons )" } { "promise" "the resulting cons object" } }
+{ $values { "car" { $quotation "( -- X )" } } { "cdr" { $quotation "( -- cons )" } } { "promise" "the resulting cons object" } }
{ $description "Constructs a cons object for a lazy list from two quotations. The " { $snippet "car" } " quotation should return the head of the list, and the " { $snippet "cons" } " quotation the tail when called. When " { $link cons } " or " { $link cdr } " are called on the lazy-cons object then the appropriate quotation is called." }
{ $see-also cons car cdr nil nil? } ;
{ 1lazy-list 2lazy-list 3lazy-list } related-words
HELP: 1lazy-list
-{ $values { "a" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
+{ $values { "a" { $quotation "( -- X )" } } { "lazy-cons" "a lazy-cons object" } }
{ $description "Create a lazy list with 1 element. The element is the result of calling the quotation. The quotation is only called when the list element is requested." } ;
HELP: 2lazy-list
-{ $values { "a" "a quotation with stack effect ( -- X )" } { "b" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
+{ $values { "a" { $quotation "( -- X )" } } { "b" { $quotation "( -- X )" } } { "lazy-cons" "a lazy-cons object" } }
{ $description "Create a lazy list with 2 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } ;
HELP: 3lazy-list
-{ $values { "a" "a quotation with stack effect ( -- X )" } { "b" "a quotation with stack effect ( -- X )" } { "c" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
+{ $values { "a" { $quotation "( -- X )" } } { "b" { $quotation "( -- X )" } } { "c" { $quotation "( -- X )" } } { "lazy-cons" "a lazy-cons object" } }
{ $description "Create a lazy list with 3 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } ;
HELP: <memoized-cons>
@@ -31,11 +31,11 @@ HELP: <memoized-cons>
{ lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words
HELP: lazy-map
-{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- X )" } { "result" "resulting cons object" } }
+{ $values { "list" "a cons object" } { "quot" { $quotation "( obj -- X )" } } { "result" "resulting cons object" } }
{ $description "Perform a similar functionality to that of the " { $link map } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-map> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
HELP: lazy-map-with
-{ $values { "value" "an object" } { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj elt -- X )" } { "result" "resulting cons object" } }
+{ $values { "value" "an object" } { "list" "a cons object" } { "quot" { $quotation "( obj elt -- X )" } } { "result" "resulting cons object" } }
{ $description "Variant of " { $link lazy-map } " which pushes a retained object on each invocation of the quotation." } ;
HELP: ltake
@@ -43,15 +43,15 @@ HELP: ltake
{ $description "Outputs a lazy list containing the first n items in the list. This is done a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-take> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
HELP: lfilter
-{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( -- X )" } { "result" "resulting cons object" } }
+{ $values { "list" "a cons object" } { "quot" { $quotation "( -- X )" } } { "result" "resulting cons object" } }
{ $description "Perform a similar functionality to that of the " { $link filter } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-filter> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
HELP: lwhile
-{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( X -- bool )" } { "result" "resulting cons object" } }
+{ $values { "list" "a cons object" } { "quot" { $quotation "( X -- ? )" } } { "result" "resulting cons object" } }
{ $description "Outputs a lazy list containing the first items in the list as long as " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link <lazy-while> } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
HELP: luntil
-{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( X -- bool )" } { "result" "resulting cons object" } }
+{ $values { "list" "a cons object" } { "quot" { $quotation "( X -- ? )" } } { "result" "resulting cons object" } }
{ $description "Outputs a lazy list containing the first items in the list until after " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link <lazy-while> } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
HELP: list>vector
@@ -69,7 +69,7 @@ HELP: lappend
{ $description "Perform a similar functionality to that of the " { $link append } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-append> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required. Successive calls to " { $link cdr } " will iterate through list1, followed by list2." } ;
HELP: lfrom-by
-{ $values { "n" "an integer" } { "quot" "a quotation with stack effect ( -- int )" } { "list" "a lazy list of integers" } }
+{ $values { "n" "an integer" } { "quot" { $quotation "( -- int )" } } { "list" "a lazy list of integers" } }
{ $description "Return an infinite lazy list of values starting from n, with each successive value being the result of applying quot to n." } ;
HELP: lfrom
@@ -101,11 +101,11 @@ HELP: lcartesian-product*
{ $description "Given a list of lists, return a list containing the cartesian product of those lists." } ;
HELP: lcomp
-{ $values { "list" "a list of lists" } { "quot" "a quotation with stack effect ( seq -- X )" } { "result" "the resulting list" } }
+{ $values { "list" "a list of lists" } { "quot" { $quotation "( seq -- X )" } } { "result" "the resulting list" } }
{ $description "Get the cartesian product of the lists in " { $snippet "list" } " and call " { $snippet "quot" } " call with each element from the cartesian product on the stack, the result of which is returned in the final " { $snippet "list" } "." } ;
HELP: lcomp*
-{ $values { "list" "a list of lists" } { "guards" "a sequence of quotations with stack effect ( seq -- bool )" } { "quot" "a quotation with stack effect ( seq -- X )" } { "list" "the resulting list" } { "result" "a list" } }
+{ $values { "list" "a list of lists" } { "guards" "a sequence of quotations with stack effect ( seq -- bool )" } { "quot" { $quotation "( seq -- X )" } } { "list" "the resulting list" } { "result" "a list" } }
{ $description "Get the cartesian product of the lists in " { $snippet "list" } ", filter it by applying each guard quotation to it and call " { $snippet "quot" } " call with each element from the remaining cartesian product items on the stack, the result of which is returned in the final " { $snippet "list" } "." }
{ $examples
{ $code "{ 1 2 3 } >list { 4 5 6 } >list 2list { [ first odd? ] } [ first2 + ] lcomp*" }
diff --git a/extra/lists/lists-docs.factor b/extra/lists/lists-docs.factor
index cd2e6f7081..8807c8cf8a 100644
--- a/extra/lists/lists-docs.factor
+++ b/extra/lists/lists-docs.factor
@@ -61,19 +61,19 @@ HELP: uncons
{ leach foldl lmap>array } related-words
HELP: leach
-{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } }
+{ $values { "list" "a cons object" } { "quot" { $quotation "( obj -- )" } } }
{ $description "Call the quotation for each item in the list." } ;
HELP: foldl
-{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } }
+{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" { $quotation "( prev elt -- next )" } } { "result" "the final result" } }
{ $description "Combines successive elements of the list (in a left-assocative order) using a binary operation and outputs the final result." } ;
HELP: foldr
-{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } }
+{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" { $quotation "( prev elt -- next )" } } { "result" "the final result" } }
{ $description "Combines successive elements of the list (in a right-assocative order) using a binary operation, and outputs the final result." } ;
HELP: lmap
-{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( old -- new )" } { "result" "the final result" } }
+{ $values { "list" "a cons object" } { "quot" { $quotation "( old -- new )" } } { "result" "the final result" } }
{ $description "Applies the quotation to each element of the list in order, collecting the new elements into a new list." } ;
HELP: lreverse
@@ -97,8 +97,8 @@ HELP: seq>cons
{ $description "Recursively turns the given sequence into a cons object, maintaing order and also converting nested lists." } ;
HELP: traverse
-{ $values { "list" "a cons object" } { "pred" "a quotation with stack effect ( list/elt -- ? )" }
- { "quot" "a quotation with stack effect ( list/elt -- result)" } { "result" "a new cons object" } }
+{ $values { "list" "a cons object" } { "pred" { $quotation "( list/elt -- ? )" } }
+ { "quot" { $quotation "( list/elt -- result)" } } { "result" "a new cons object" } }
{ $description "Recursively traverses the list object, replacing any elements (which can themselves be sublists) that pred"
" returns true for with the result of applying quot to." } ;
diff --git a/extra/promises/promises-docs.factor b/extra/promises/promises-docs.factor
index c482df0d15..4e8dc9a9a2 100755
--- a/extra/promises/promises-docs.factor
+++ b/extra/promises/promises-docs.factor
@@ -5,17 +5,17 @@ USING: help.markup help.syntax ;
IN: promises
HELP: promise
-{ $values { "quot" "a quotation with stack effect ( -- X )" } { "promise" "a promise object" } }
+{ $values { "quot" { $quotation "( -- X )" } } { "promise" "a promise object" } }
{ $description "Creates a promise to return a value. When forced this quotation is called and the value returned. The value is memorised so that calling " { $link force } " again does not call the quotation again, instead the previous value is returned directly." }
{ $see-also force promise-with promise-with2 } ;
HELP: promise-with
-{ $values { "value" "an object" } { "quot" "a quotation with stack effect ( value -- X )" } { "promise" "a promise object" } }
+{ $values { "value" "an object" } { "quot" { $quotation "( value -- X )" } } { "promise" "a promise object" } }
{ $description "Creates a promise to return a value. When forced this quotation is called with the given value on the stack and the result returned. The value is memorised so that calling " { $link force } " again does not call the quotation again, instead the previous value is returned directly." }
{ $see-also force promise promise-with2 } ;
HELP: promise-with2
-{ $values { "value1" "an object" } { "value2" "an object" } { "quot" "a quotation with stack effect ( value1 value2 -- X )" } { "promise" "a promise object" } }
+{ $values { "value1" "an object" } { "value2" "an object" } { "quot" { $quotation "( value1 value2 -- X )" } } { "promise" "a promise object" } }
{ $description "Creates a promise to return a value. When forced this quotation is called with the given values on the stack and the result returned. The value is memorised so that calling " { $link force } " again does not call the quotation again, instead the previous value is returned directly." }
{ $see-also force promise promise-with2 } ;
From 96bb916c35523456ed94ab7db977b95066580f3a Mon Sep 17 00:00:00 2001
From: "Jose A. Ortega Ruiz" <jao@gnu.org>
Date: Sun, 16 Nov 2008 16:21:47 +0100
Subject: [PATCH 121/157] Indentation in Emacs factor-mode: customizable width
and no tabs.
---
misc/factor.el | 75 ++++++++++++++++++++++++++++++++++----------------
1 file changed, 52 insertions(+), 23 deletions(-)
diff --git a/misc/factor.el b/misc/factor.el
index b25493dd5e..2d222187e4 100644
--- a/misc/factor.el
+++ b/misc/factor.el
@@ -17,24 +17,43 @@
;; M-x run-factor === Start a Factor listener inside Emacs
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Customization
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defgroup factor nil
"Factor mode"
:group 'languages)
-(defvar factor-mode-syntax-table nil
- "Syntax table used while in Factor mode.")
+(defcustom factor-default-indent-width 4
+ "Default indentantion width for factor-mode.
+
+This value will be used for the local variable
+`factor-indent-width' in new factor buffers. For existing code,
+we first check if `factor-indent-width' is set explicitly in a
+local variable section or line (e.g. '! -*- factor-indent-witdth: 2 -*-').
+If that's not the case, `factor-mode' tries to infer its correct
+value from the existing code in the buffer."
+ :type 'integer
+ :group 'factor)
(defcustom factor-display-compilation-output t
"Display the REPL buffer before compiling files."
:type '(choice (const :tag "Enable" t) (const :tag "Disable" nil))
:group 'factor)
+(defcustom factor-mode-hook nil
+ "Hook run when entering Factor mode."
+ :type 'hook
+ :group 'factor)
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; factor-mode syntax
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defvar factor-mode-syntax-table nil
+ "Syntax table used while in Factor mode.")
+
(if factor-mode-syntax-table
()
(let ((i 0))
@@ -75,11 +94,6 @@
(modify-syntax-entry ?\) ")(" factor-mode-syntax-table)
(modify-syntax-entry ?\" "\" " factor-mode-syntax-table)))
-(defcustom factor-mode-hook nil
- "Hook run when entering Factor mode."
- :type 'hook
- :group 'factor)
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; factor-mode font lock
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -146,7 +160,7 @@
"initial:" "inline" "parsing" "read-only" "recursive")
'words))
-(defun factor--regex-second-word (prefixes)
+(defsubst factor--regex-second-word (prefixes)
(format "^%s +\\([^ \r\n]+\\)" (regexp-opt prefixes t)))
(defconst factor--regex-word-definition
@@ -290,10 +304,6 @@
;; factor-mode indentation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defun factor-indent-line ()
- "Indent current line as Factor code"
- (indent-line-to (+ (current-indentation) 4)))
-
(defconst factor-word-starting-keywords
'("" ":" "TUPLE" "MACRO" "MACRO:" "M"))
@@ -302,6 +312,26 @@
"^\\(%s\\): "
(mapconcat 'identity ,keywords "\\|")))
+(defvar factor-indent-width factor-default-indent-width
+ "Indentation width in factor buffers. A local variable.")
+
+(make-variable-buffer-local 'factor-indent-width)
+
+(defun factor--guess-indent-width ()
+ "Chooses an indentation value from existing code."
+ (let ((word-def (factor-word-start-re factor-word-starting-keywords))
+ (word-cont "^ +[^ ]")
+ (iw))
+ (save-excursion
+ (beginning-of-buffer)
+ (while (not iw)
+ (if (not (re-search-forward word-def nil t))
+ (setq iw factor-default-indent-width)
+ (forward-line)
+ (when (looking-at word-cont)
+ (setq iw (current-indentation))))))
+ iw))
+
(defun factor-calculate-indentation ()
"Calculate Factor indentation for line at point."
(let ((not-indented t)
@@ -317,21 +347,21 @@
(let ((cur-depth (factor-brackets-depth)))
(forward-line -1)
(setq cur-indent (+ (current-indentation)
- (* default-tab-width
+ (* factor-indent-width
(- cur-depth (factor-brackets-depth)))))
(setq not-indented nil)))
(forward-line -1)
;; Check that we are after the end of previous word
(if (looking-at ".*;[ \t]*$")
(progn
- (setq cur-indent (- (current-indentation) default-tab-width))
+ (setq cur-indent (- (current-indentation) factor-indent-width))
(setq not-indented nil))
;; Check that we are after the start of word
(if (looking-at (factor-word-start-re factor-word-starting-keywords))
; (if (looking-at "^[A-Z:]*: ")
(progn
(message "inword")
- (setq cur-indent (+ (current-indentation) default-tab-width))
+ (setq cur-indent (+ (current-indentation) factor-indent-width))
(setq not-indented nil))
(if (bobp)
(setq not-indented nil))))))))
@@ -369,14 +399,13 @@
(setq major-mode 'factor-mode)
(setq mode-name "Factor")
(set (make-local-variable 'indent-line-function) #'factor-indent-line)
- (make-local-variable 'comment-start)
- (setq comment-start "! ")
- (make-local-variable 'font-lock-defaults)
- (setq font-lock-defaults
- '(factor-font-lock-keywords t nil nil nil))
+ (set (make-local-variable 'comment-start) "! ")
+ (set (make-local-variable 'font-lock-defaults)
+ '(factor-font-lock-keywords t nil nil nil))
(set-syntax-table factor-mode-syntax-table)
- (make-local-variable 'indent-line-function)
- (setq indent-line-function 'factor-indent-line)
+ (set (make-local-variable 'indent-line-function) 'factor-indent-line)
+ (setq factor-indent-width (factor--guess-indent-width))
+ (setq indent-tabs-mode nil)
(run-hooks 'factor-mode-hook))
(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))
From e9a42b9bde3980120140cbf494c3ff76077e34a2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 10:31:04 -0600
Subject: [PATCH 122/157] Fix help-lint
---
basis/help/markup/markup.factor | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor
index ae3c3fa7de..a307833338 100644
--- a/basis/help/markup/markup.factor
+++ b/basis/help/markup/markup.factor
@@ -249,12 +249,12 @@ M: string ($instance)
M: f ($instance)
drop { f } $link ;
-: $instance ( children -- ) first ($instance) ;
+: $instance ( element -- ) first ($instance) ;
-: $maybe ( children -- )
+: $maybe ( element -- )
$instance " or " print-element { f } $instance ;
-: $quotation ( children -- )
+: $quotation ( element -- )
{ "a " { $link quotation } " with stack effect " } print-element
$snippet ;
From b917e1f051699c9854003af5d19d57fef06bf206 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 10:31:12 -0600
Subject: [PATCH 123/157] Document furnace
---
basis/furnace/furnace-docs.factor | 171 ++++++++++----------
basis/furnace/furnace.factor | 2 +-
basis/furnace/referrer/referrer-docs.factor | 8 +-
3 files changed, 90 insertions(+), 91 deletions(-)
diff --git a/basis/furnace/furnace-docs.factor b/basis/furnace/furnace-docs.factor
index 4b8c877ca8..b86d4c3295 100644
--- a/basis/furnace/furnace-docs.factor
+++ b/basis/furnace/furnace-docs.factor
@@ -1,136 +1,129 @@
USING: assocs help.markup help.syntax kernel
-quotations sequences strings urls ;
+quotations sequences strings urls xml.data http ;
IN: furnace
HELP: adjust-redirect-url
{ $values { "url" url } { "url'" url } }
-{ $description "" } ;
+{ $description "Adjusts a redirection URL by filtering the URL's query parameters through the " { $link modify-redirect-query } " generic word on every responder involved in handling the current request." } ;
HELP: adjust-url
{ $values { "url" url } { "url'" url } }
-{ $description "" } ;
-
-HELP: base-path
-{ $values { "string" string } { "pair" "a pair with shape " { $snippet "{ path responder }" } } }
-{ $description "" } ;
+{ $description "Adjusts a link URL by filtering the URL's query parameters through the " { $link modify-query } " generic word on every responder involved in handling the current request." } ;
HELP: client-state
{ $values { "key" string } { "value/f" { $maybe string } } }
-{ $description "" } ;
+{ $description "Looks up a cookie (if the current request is a GET or HEAD request) or a POST parameter (if the current request is a POST request)." }
+{ $notes "This word is used by session management, conversation scope and asides." } ;
HELP: each-responder
-{ $values { "quot" "a " { $link quotation } " with stack effect " { $snippet "( responder -- )" } } }
-{ $description "" } ;
-
-HELP: exit-with
-{ $values
- { "value" null }
-}
-{ $description "" } ;
+{ $values { "quot" { $quotation "( responder -- )" } } }
+{ $description "Applies the quotation to each responder involved in processing the current request." } ;
HELP: hidden-form-field
-{ $values
- { "value" null } { "name" null }
-}
-{ $description "" } ;
+{ $values { "value" string } { "name" string } }
+{ $description "Renders an HTML hidden form field tag." }
+{ $notes "This word is used by session management, conversation scope and asides." }
+{ $examples
+ { $example
+ "USING: furnace io ;"
+ "\"bar\" \"foo\" hidden-form-field nl"
+ "<input type='hidden' name='foo' value='bar'/>"
+ }
+} ;
HELP: link-attr
-{ $values
- { "tag" null } { "responder" null }
-}
-{ $description "" } ;
+{ $values { "tag" tag } { "responder" "a responder" } }
+{ $contract "Modifies an XHTML " { $snippet "a" } " tag." }
+{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." }
+{ $examples "Conversation scope adds attributes to link tags." } ;
HELP: modify-form
-{ $values
- { "responder" null }
-}
-{ $description "" } ;
+{ $values { "responder" "a responder" } }
+{ $contract "Emits hidden form fields using " { $link hidden-form-field } "." }
+{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." }
+{ $examples "Session management, conversation scope and asides use hidden form fields to pass state." } ;
HELP: modify-query
-{ $values
- { "query" null } { "responder" null }
- { "query'" null }
-}
-{ $description "" } ;
+{ $values { "query" assoc } { "responder" "a responder" } { "query'" assoc } }
+{ $contract "Modifies the query parameters of a URL destined to be displayed as a link." }
+{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." }
+{ $examples "Asides add query parameters to URLs." } ;
HELP: modify-redirect-query
-{ $values
- { "query" null } { "responder" null }
- { "query'" null }
-}
-{ $description "" } ;
-
-HELP: nested-forms-key
-{ $description "" } ;
+{ $values { "query" assoc } { "responder" "a responder" } { "query'" assoc } }
+{ $contract "Modifies the query parameters of a URL destined to be used with a redirect." }
+{ $notes "This word is called by " { $link "furnace.redirection" } "." }
+{ $examples "Conversation scope and asides add query parameters to redirect URLs." } ;
HELP: nested-responders
-{ $values
-
- { "seq" sequence }
-}
-{ $description "" } ;
-
-HELP: post-client-state
-{ $values
- { "key" null } { "request" null }
- { "value/f" null }
-}
+{ $values { "seq" "a sequence of responders" } }
{ $description "" } ;
HELP: referrer
-{ $values
-
- { "referrer/f" null }
-}
-{ $description "" } ;
+{ $values { "referrer/f" { $maybe string } } }
+{ $description "Outputs the current request's referrer URL." } ;
HELP: request-params
-{ $values
- { "request" null }
- { "assoc" assoc }
-}
-{ $description "" } ;
+{ $values { "request" request } { "assoc" assoc } }
+{ $description "Outputs the query parameters (if the current request is a GET or HEAD request) or the POST parameters (if the current request is a POST request)." } ;
HELP: resolve-base-path
-{ $values
- { "string" string }
- { "string'" string }
-}
+{ $values { "string" string } { "string'" string } }
{ $description "" } ;
HELP: resolve-template-path
-{ $values
- { "pair" null }
- { "path" "a pathname string" }
-}
+{ $values { "pair" "a pair with shape " { $snippet "{ class string }" } } { "path" "a pathname string" } }
{ $description "" } ;
HELP: same-host?
-{ $values
- { "url" url }
- { "?" "a boolean" }
-}
-{ $description "" } ;
+{ $values { "url" url } { "?" "a boolean" } }
+{ $description "Tests if the given URL is located on the same host as the URL of the current request." } ;
HELP: user-agent
-{ $values
-
- { "user-agent" null }
-}
-{ $description "" } ;
+{ $values { "user-agent" { $maybe string } } }
+{ $description "Outputs the user agent reported by the client for the current request." } ;
HELP: vocab-path
-{ $values
- { "vocab" "a vocabulary specifier" }
- { "path" "a pathname string" }
-}
+{ $values { "vocab" "a vocabulary specifier" } { "path" "a pathname string" } }
{ $description "" } ;
+HELP: exit-with
+{ $values { "value" object } }
+{ $description "Exits from an outer " { $link with-exit-continuation } "." } ;
+
HELP: with-exit-continuation
-{ $values
- { "quot" quotation }
-}
-{ $description "" } ;
+{ $values { "quot" { $quotation { "( -- value )" } } } { "value" "a value returned by the quotation or an " { $link exit-with } " invocation" } }
+{ $description "Runs a quotation with the " { $link exit-continuation } " variable bound. Calling " { $link exit-with } " in the quotation will immediately return." }
+{ $notes "Furnace actions and authentication realms wrap their execution in this combinator, allowing form validation failures and login requests, respectively, to immediately return an HTTP response to the client without running any more responder code." } ;
+
+ARTICLE: "furnace.extension-points" "Furnace extension points"
+"Furnace features such as session management, conversation scope and asides need to modify URLs in links and redirects, and insert hidden form fields, to implement state on top of the setateless HTTP protocol. In order to decouple the server-side state management code from the HTML templating code, a series of hooks are used."
+$nl
+"Responders can implement methods on the following generic words:"
+{ $subsection modify-query }
+{ $subsection modify-redirect-query }
+{ $subsection link-attr }
+{ $subsection modify-form }
+"Presentation-level code can call the following words:"
+{ $subsection adjust-url }
+{ $subsection adjust-redirect-url } ;
+
+ARTICLE: "furnace.misc" "Miscellaneous Furnace features"
+"Inspecting the chain of responders handling the current request:"
+{ $subsection nested-responders }
+{ $subsection each-responder }
+{ $subsection resolve-base-path }
+"Vocabulary root-relative resources:"
+{ $subsection vocab-path }
+{ $subsection resolve-template-path }
+"Early return from a responder:"
+{ $subsection with-exit-continuation }
+{ $subsection exit-with }
+"Other useful words:"
+{ $subsection hidden-form-field }
+{ $subsection request-params }
+{ $subsection client-state }
+{ $subsection user-agent } ;
ARTICLE: "furnace.persistence" "Furnace persistence layer"
{ $subsection "furnace.db" }
@@ -175,6 +168,8 @@ ARTICLE: "furnace" "Furnace framework"
"Utilities:"
{ $subsection "furnace.referrer" }
{ $subsection "furnace.redirection" }
+{ $subsection "furnace.extension-points" }
+{ $subsection "furnace.misc" }
"Related frameworks:"
{ $subsection "db" }
{ $subsection "xml" }
diff --git a/basis/furnace/furnace.factor b/basis/furnace/furnace.factor
index 841a7087c3..29eb00a8f4 100644
--- a/basis/furnace/furnace.factor
+++ b/basis/furnace/furnace.factor
@@ -125,7 +125,7 @@ SYMBOL: exit-continuation
: exit-with ( value -- )
exit-continuation get continue-with ;
-: with-exit-continuation ( quot -- )
+: with-exit-continuation ( quot -- value )
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
USE: vocabs.loader
diff --git a/basis/furnace/referrer/referrer-docs.factor b/basis/furnace/referrer/referrer-docs.factor
index 5deebbe9a7..599461c37c 100644
--- a/basis/furnace/referrer/referrer-docs.factor
+++ b/basis/furnace/referrer/referrer-docs.factor
@@ -1,4 +1,5 @@
-USING: help.markup help.syntax io.streams.string ;
+USING: help.markup help.syntax io.streams.string
+furnace ;
IN: furnace.referrer
HELP: <check-form-submissions>
@@ -10,6 +11,9 @@ HELP: <check-form-submissions>
ARTICLE: "furnace.referrer" "Form submission referrer checking"
"The " { $vocab-link "furnace.referrer" } " implements a simple security measure which can be used to thwart cross-site scripting attacks."
-{ $subsection <check-form-submissions> } ;
+{ $subsection <check-form-submissions> }
+"Explicit referrer checking:"
+{ $subsection referrer }
+{ $subsection same-host? } ;
ABOUT: "furnace.referrer"
From e38bc79e06d83d2b00bc747384cb280a8dd81a7a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 11:29:35 -0600
Subject: [PATCH 124/157] mason now generates HTML documentation using
help.html
---
basis/help/html/html.factor | 18 ++++-----
extra/mason/common/common.factor | 10 ++++-
extra/mason/config/config.factor | 19 +++++++--
extra/mason/help/help.factor | 23 +++++++++++
extra/mason/release/branch/branch.factor | 2 +-
.../mason/release/upload/upload-tests.factor | 36 +----------------
extra/mason/release/upload/upload.factor | 40 ++++---------------
extra/mason/report/report.factor | 1 +
extra/mason/test/test.factor | 3 +-
9 files changed, 68 insertions(+), 84 deletions(-)
create mode 100644 extra/mason/help/help.factor
diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor
index 8cefb4c112..c9e24f0091 100644
--- a/basis/help/html/html.factor
+++ b/basis/help/html/html.factor
@@ -92,16 +92,14 @@ M: topic browser-link-href topic>filename ;
all-topics [ help>html ] each ;
: generate-help ( -- )
- { "resource:core" "resource:basis" "resource:extra" } vocab-roots [
- load-everything
-
- "/tmp/docs/" make-directory
-
- "/tmp/docs/" [
+ "docs" temp-file
+ [ make-directories ]
+ [
+ [
generate-indices
generate-help-files
] with-directory
- ] with-variable ;
+ ] bi ;
MEMO: load-index ( name -- index )
binary file-contents bytes>object ;
@@ -119,10 +117,10 @@ M: result link-href href>> ;
[ [ title>> ] compare ] sort ;
: article-apropos ( string -- results )
- "articles.idx" offline-apropos ;
+ "articles.idx" temp-file offline-apropos ;
: word-apropos ( string -- results )
- "words.idx" offline-apropos ;
+ "words.idx" temp-file offline-apropos ;
: vocab-apropos ( string -- results )
- "vocabs.idx" offline-apropos ;
+ "vocabs.idx" temp-file offline-apropos ;
diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor
index dfda85e4d7..24a1292be3 100644
--- a/extra/mason/common/common.factor
+++ b/extra/mason/common/common.factor
@@ -3,7 +3,7 @@
USING: kernel namespaces sequences splitting system accessors
math.functions make io io.files io.launcher io.encodings.utf8
prettyprint combinators.short-circuit parser combinators
-calendar calendar.format arrays mason.config ;
+calendar calendar.format arrays mason.config locals ;
IN: mason.common
: short-running-process ( command -- )
@@ -13,6 +13,13 @@ IN: mason.common
15 minutes >>timeout
try-process ;
+:: upload-safely ( local username host remote -- )
+ [let* | temp [ remote ".incomplete" append ]
+ scp-remote [ { username "@" host ":" temp } concat ] |
+ { "scp" local scp-remote } short-running-process
+ { "ssh" host "-l" username "mv" temp remote } short-running-process
+ ] ;
+
: eval-file ( file -- obj )
dup utf8 file-lines parse-fresh
[ "Empty file: " swap append throw ] [ nip first ] if-empty ;
@@ -71,6 +78,7 @@ SYMBOL: stamp
: test-time-file "test-time" ;
: help-lint-time-file "help-lint-time" ;
: benchmark-time-file "benchmark-time" ;
+: html-help-time-file "html-help-time" ;
: benchmarks-file "benchmarks" ;
diff --git a/extra/mason/config/config.factor b/extra/mason/config/config.factor
index 0ce059c995..e4ef127413 100644
--- a/extra/mason/config/config.factor
+++ b/extra/mason/config/config.factor
@@ -33,10 +33,23 @@ target-os get-global [
! Keep test-log around?
SYMBOL: builder-debug
-! Boolean. Do we release binaries and update the clean branch?
-SYMBOL: upload-to-factorcode
+SYMBOL: upload-help?
-! The below are only needed if upload-to-factorcode is true.
+! The below are only needed if upload-help is true.
+
+! Host with HTML help
+SYMBOL: help-host
+
+! Username to log in.
+SYMBOL: help-username
+
+! Directory to upload docs to.
+SYMBOL: help-directory
+
+! Boolean. Do we release binaries and update the clean branch?
+SYMBOL: upload-to-factorcode?
+
+! The below are only needed if upload-to-factorcode? is true.
! Host with clean git repo.
SYMBOL: branch-host
diff --git a/extra/mason/help/help.factor b/extra/mason/help/help.factor
new file mode 100644
index 0000000000..1e3e1509c9
--- /dev/null
+++ b/extra/mason/help/help.factor
@@ -0,0 +1,23 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.html sequences io.files io.launcher make namespaces
+kernel arrays mason.common mason.config ;
+IN: mason.help
+
+: make-help-archive ( -- )
+ "factor/temp" [
+ { "tar" "cfz" "docs.tar.gz" "docs" } try-process
+ ] with-directory ;
+
+: upload-help-archive ( -- )
+ "factor/temp/docs.tar.gz"
+ help-username get
+ help-host get
+ help-directory get "/docs.tar.gz" append
+ upload-safely ;
+
+: upload-help ( -- )
+ upload-help? get [
+ make-help-archive
+ upload-help-archive
+ ] when ;
diff --git a/extra/mason/release/branch/branch.factor b/extra/mason/release/branch/branch.factor
index 8872cda5b5..ff2632a9b3 100644
--- a/extra/mason/release/branch/branch.factor
+++ b/extra/mason/release/branch/branch.factor
@@ -45,4 +45,4 @@ IN: mason.release.branch
] with-directory ;
: update-clean-branch ( -- )
- upload-to-factorcode get [ (update-clean-branch) ] when ;
+ upload-to-factorcode? get [ (update-clean-branch) ] when ;
diff --git a/extra/mason/release/upload/upload-tests.factor b/extra/mason/release/upload/upload-tests.factor
index 9f5300b129..73fc311399 100644
--- a/extra/mason/release/upload/upload-tests.factor
+++ b/extra/mason/release/upload/upload-tests.factor
@@ -1,38 +1,4 @@
IN: mason.release.upload.tests
-USING: mason.release.upload mason.common mason.config
-mason.common namespaces calendar tools.test ;
-
-[
- {
- "scp"
- "factor-linux-ppc-2008-09-11-23-12.tar.gz"
- "slava@www.apple.com:/uploads/linux-ppc/factor-linux-ppc-2008-09-11-23-12.tar.gz.incomplete"
- }
- {
- "ssh"
- "www.apple.com"
- "-l" "slava"
- "mv"
- "/uploads/linux-ppc/factor-linux-ppc-2008-09-11-23-12.tar.gz.incomplete"
- "/uploads/linux-ppc/factor-linux-ppc-2008-09-11-23-12.tar.gz"
- }
-] [
- [
- "slava" upload-username set
- "www.apple.com" upload-host set
- "/uploads" upload-directory set
- "linux" target-os set
- "ppc" target-cpu set
- T{ timestamp
- { year 2008 }
- { month 09 }
- { day 11 }
- { hour 23 }
- { minute 12 }
- } datestamp stamp set
- upload-command
- rename-command
- ] with-scope
-] unit-test
+USING: mason.release.upload tools.test ;
\ upload must-infer
diff --git a/extra/mason/release/upload/upload.factor b/extra/mason/release/upload/upload.factor
index 2bf18f1126..68f2ffcdb5 100644
--- a/extra/mason/release/upload/upload.factor
+++ b/extra/mason/release/upload/upload.factor
@@ -11,37 +11,11 @@ IN: mason.release.upload
: remote-archive-name ( -- dest )
remote-location "/" archive-name 3append ;
-: temp-archive-name ( -- dest )
- remote-archive-name ".incomplete" append ;
-
-: upload-command ( -- args )
- "scp"
- archive-name
- [
- upload-username get % "@" %
- upload-host get % ":" %
- temp-archive-name %
- ] "" make
- 3array ;
-
-: rename-command ( -- args )
- [
- "ssh" ,
- upload-host get ,
- "-l" ,
- upload-username get ,
- "mv" ,
- temp-archive-name ,
- remote-archive-name ,
- ] { } make ;
-
-: upload-temp-file ( -- )
- upload-command short-running-process ;
-
-: rename-temp-file ( -- )
- rename-command short-running-process ;
-
: upload ( -- )
- upload-to-factorcode get
- [ upload-temp-file rename-temp-file ]
- when ;
+ upload-to-factorcode? get [
+ archive-name
+ upload-username get
+ upload-host get
+ remote-archive-name
+ upload-safely
+ ] when ;
diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor
index 145686d621..0b5f21540a 100644
--- a/extra/mason/report/report.factor
+++ b/extra/mason/report/report.factor
@@ -46,6 +46,7 @@ IN: mason.report
test-time-file time.
help-lint-time-file time.
benchmark-time-file time.
+ html-help-time-file time.
nl
diff --git a/extra/mason/test/test.factor b/extra/mason/test/test.factor
index 58884175a3..8f35b08dea 100644
--- a/extra/mason/test/test.factor
+++ b/extra/mason/test/test.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces assocs io.files io.encodings.utf8
prettyprint help.lint benchmark tools.time bootstrap.stage2
-tools.test tools.vocabs mason.common ;
+tools.test tools.vocabs help.html mason.common ;
IN: mason.test
: do-load ( -- )
@@ -33,6 +33,7 @@ IN: mason.test
[ do-tests ] benchmark test-time-file to-file
[ do-help-lint ] benchmark help-lint-time-file to-file
[ do-benchmarks ] benchmark benchmark-time-file to-file
+ [ generate-help ] benchmark html-help-time-file to-file
] with-directory ;
MAIN: do-all
\ No newline at end of file
From 143f078dd85650eb2d804a20cdec03652c2f2e5c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 11:33:38 -0600
Subject: [PATCH 125/157] Fix io.sockets docs for when io.sockets.secure isn't
loaded
---
basis/io/sockets/sockets-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/io/sockets/sockets-docs.factor b/basis/io/sockets/sockets-docs.factor
index 3454f3384e..25401293f5 100644
--- a/basis/io/sockets/sockets-docs.factor
+++ b/basis/io/sockets/sockets-docs.factor
@@ -56,7 +56,7 @@ ARTICLE: "network-streams" "Networking"
{ $subsection "network-addressing" }
{ $subsection "network-connection" }
{ $subsection "network-packet" }
-{ $subsection "io.sockets.secure" }
+{ $vocab-subsection "Secure sockets (SSL, TLS)" "io.sockets.secure" }
{ $see-also "io.pipes" } ;
ABOUT: "network-streams"
From 3061fe117d1ffdce54c6892a1134161b08d6b6c7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 11:49:20 -0600
Subject: [PATCH 126/157] Generate help before running tests
---
extra/mason/test/test.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/mason/test/test.factor b/extra/mason/test/test.factor
index 8f35b08dea..cc83c9db44 100644
--- a/extra/mason/test/test.factor
+++ b/extra/mason/test/test.factor
@@ -30,10 +30,10 @@ IN: mason.test
".." [
bootstrap-time get boot-time-file to-file
[ do-load ] benchmark load-time-file to-file
+ [ generate-help ] benchmark html-help-time-file to-file
[ do-tests ] benchmark test-time-file to-file
[ do-help-lint ] benchmark help-lint-time-file to-file
[ do-benchmarks ] benchmark benchmark-time-file to-file
- [ generate-help ] benchmark html-help-time-file to-file
] with-directory ;
MAIN: do-all
\ No newline at end of file
From 63d109cc041fa758d0c9700decb91386a9305625 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 11:49:32 -0600
Subject: [PATCH 127/157] Remove unused F_CURRY struct from layouts.h
---
vm/layouts.h | 8 --------
1 file changed, 8 deletions(-)
diff --git a/vm/layouts.h b/vm/layouts.h
index 6dc29efdae..e55a5e9fd3 100755
--- a/vm/layouts.h
+++ b/vm/layouts.h
@@ -201,14 +201,6 @@ typedef struct {
void *dll;
} F_DLL;
-typedef struct {
- CELL header;
- /* tagged */
- CELL obj;
- /* tagged */
- CELL quot;
-} F_CURRY;
-
typedef struct {
CELL header;
/* tagged */
From cd3c71c113d00bda2833bff9e6efb3e224e686a8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 11:54:26 -0600
Subject: [PATCH 128/157] Add exception handling to help.html
---
basis/help/html/html.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor
index c9e24f0091..4100a34d72 100644
--- a/basis/help/html/html.factor
+++ b/basis/help/html/html.factor
@@ -5,7 +5,7 @@ io.files html.streams html.elements html.components 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 ;
+sorting debugger ;
IN: help.html
: escape-char ( ch -- )
@@ -89,7 +89,7 @@ M: topic browser-link-href topic>filename ;
all-vocabs-really [ dup vocab-name ] { } map>assoc "vocabs.idx" serialize-index ;
: generate-help-files ( -- )
- all-topics [ help>html ] each ;
+ all-topics [ '[ _ help>html ] try ] each ;
: generate-help ( -- )
"docs" temp-file
From 77b77d6414294929de57c66e6b5f9450f201d66a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 13:07:03 -0600
Subject: [PATCH 129/157] gl-rect stack effect changed
---
extra/springies/ui/ui.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/springies/ui/ui.factor b/extra/springies/ui/ui.factor
index 07865f38e0..21e97a1827 100644
--- a/extra/springies/ui/ui.factor
+++ b/extra/springies/ui/ui.factor
@@ -7,7 +7,7 @@ IN: springies.ui
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: draw-node ( node -- ) pos>> { -5 -5 } v+ dup { 10 10 } v+ gl-rect ;
+: draw-node ( node -- ) pos>> { -5 -5 } v+ [ { 10 10 } gl-rect ] with-translation ;
: draw-spring ( spring -- )
[ node-a>> pos>> ] [ node-b>> pos>> ] bi gl-line ;
From e6218fdc7180fa9003a8f6ee801f5b636c823cea Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 13:46:21 -0600
Subject: [PATCH 130/157] Move words from compiler.errors.private to
compiler.errors
---
core/compiler/errors/errors-docs.factor | 2 +-
core/compiler/errors/errors.factor | 4 ----
2 files changed, 1 insertion(+), 5 deletions(-)
diff --git a/core/compiler/errors/errors-docs.factor b/core/compiler/errors/errors-docs.factor
index d86587662b..cb896dbf53 100644
--- a/core/compiler/errors/errors-docs.factor
+++ b/core/compiler/errors/errors-docs.factor
@@ -1,6 +1,6 @@
IN: compiler.errors
USING: help.markup help.syntax vocabs.loader words io
-quotations compiler.errors.private ;
+quotations ;
ARTICLE: "compiler-errors" "Compiler warnings and errors"
"The compiler saves various notifications in a global variable:"
diff --git a/core/compiler/errors/errors.factor b/core/compiler/errors/errors.factor
index 7a28c1fb99..c2452f719d 100644
--- a/core/compiler/errors/errors.factor
+++ b/core/compiler/errors/errors.factor
@@ -14,8 +14,6 @@ M: object compiler-error-type drop +error+ ;
GENERIC# compiler-error. 1 ( error word -- )
-<PRIVATE
-
SYMBOL: compiler-errors
SYMBOL: with-compiler-errors?
@@ -47,8 +45,6 @@ SYMBOL: with-compiler-errors?
"semantic warnings" +warning+ "warnings" (compiler-report)
"linkage errors" +linkage+ "linkage" (compiler-report) ;
-PRIVATE>
-
: :errors ( -- ) +error+ compiler-errors. ;
: :warnings ( -- ) +warning+ compiler-errors. ;
From 105831fabec6bb4dd3541466a6b8f720ed88473d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 13:46:30 -0600
Subject: [PATCH 131/157] Update for compiler.errors change
---
basis/tools/deploy/shaker/shaker.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor
index a7332ea9ea..f8f9680c16 100755
--- a/basis/tools/deploy/shaker/shaker.factor
+++ b/basis/tools/deploy/shaker/shaker.factor
@@ -9,7 +9,7 @@ sorting compiler.units definitions ;
QUALIFIED: bootstrap.stage2
QUALIFIED: classes
QUALIFIED: command-line
-QUALIFIED: compiler.errors.private
+QUALIFIED: compiler.errors
QUALIFIED: continuations
QUALIFIED: definitions
QUALIFIED: init
@@ -291,7 +291,7 @@ IN: tools.deploy.shaker
strip-debugger? [
{
- compiler.errors.private:compiler-errors
+ compiler.errors:compiler-errors
continuations:thread-error-hook
} %
] when
From 437d59498220fbe39095c1d5a854c5f0407b9741 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 13:46:45 -0600
Subject: [PATCH 132/157] Put compiler errors in build report
---
extra/mason/child/child.factor | 1 +
extra/mason/common/common.factor | 1 +
extra/mason/report/report.factor | 29 ++++++++++++++++++-----------
extra/mason/test/test.factor | 18 ++++++++++++++++--
4 files changed, 36 insertions(+), 13 deletions(-)
diff --git a/extra/mason/child/child.factor b/extra/mason/child/child.factor
index 02085a89b3..2bc6b191c4 100644
--- a/extra/mason/child/child.factor
+++ b/extra/mason/child/child.factor
@@ -61,6 +61,7 @@ IN: mason.child
[ load-everything-vocabs-file eval-file empty? ]
[ test-all-vocabs-file eval-file empty? ]
[ help-lint-vocabs-file eval-file empty? ]
+ [ compiler-errors-file eval-file empty? ]
} 0&& ;
: build-child ( -- )
diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor
index 24a1292be3..fc7149e181 100644
--- a/extra/mason/common/common.factor
+++ b/extra/mason/common/common.factor
@@ -75,6 +75,7 @@ SYMBOL: stamp
: boot-time-file "boot-time" ;
: load-time-file "load-time" ;
+: compiler-errors-file "compiler-errors" ;
: test-time-file "test-time" ;
: help-lint-time-file "help-lint-time" ;
: benchmark-time-file "benchmark-time" ;
diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor
index 0b5f21540a..1b2697a5d1 100644
--- a/extra/mason/report/report.factor
+++ b/extra/mason/report/report.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces debugger fry io io.files io.sockets
io.encodings.utf8 prettyprint benchmark mason.common
-mason.platform mason.config ;
+mason.platform mason.config sequences ;
IN: mason.report
: time. ( file -- )
@@ -50,18 +50,25 @@ IN: mason.report
nl
- "Did not pass load-everything:" print
- load-everything-vocabs-file cat
- load-everything-errors-file cat
+ load-everything-vocabs-file eval-file [
+ "== Did not pass load-everything:" print .
+ load-everything-errors-file cat
+ ] unless-empty
- "Did not pass test-all:" print
- test-all-vocabs-file cat
- test-all-errors-file cat
+ compiler-errors-file eval-file [
+ "== Vocabularies with compiler errors:" print .
+ ] unless-empty
- "Did not pass help-lint:" print
- help-lint-vocabs-file cat
- help-lint-errors-file cat
+ test-all-vocabs-file eval-file [
+ "== Did not pass test-all:" print .
+ test-all-errors-file cat
+ ] unless-empty
- "Benchmarks:" print
+ help-lint-vocabs-file eval-file [
+ "== Did not pass help-lint:" print .
+ help-lint-errors-file cat
+ ] unless-empty
+
+ "== Benchmarks:" print
benchmarks-file eval-file benchmarks.
] with-report ;
\ No newline at end of file
diff --git a/extra/mason/test/test.factor b/extra/mason/test/test.factor
index cc83c9db44..760b51617d 100644
--- a/extra/mason/test/test.factor
+++ b/extra/mason/test/test.factor
@@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces assocs io.files io.encodings.utf8
prettyprint help.lint benchmark tools.time bootstrap.stage2
-tools.test tools.vocabs help.html mason.common ;
+tools.test tools.vocabs help.html mason.common words generic
+accessors compiler.errors sequences sets sorting ;
IN: mason.test
: do-load ( -- )
@@ -11,6 +12,19 @@ IN: mason.test
[ load-everything-errors-file utf8 [ load-failures. ] with-file-writer ]
bi ;
+GENERIC: word-vocabulary ( word -- vocabulary )
+
+M: word word-vocabulary vocabulary>> ;
+
+M: method-body word-vocabulary "method-generic" word-prop ;
+
+: do-compile-errors ( -- )
+ compiler-errors-file utf8 [
+ +error+ errors-of-type keys
+ [ word-vocabulary ] map
+ prune natural-sort .
+ ] with-file-writer ;
+
: do-tests ( -- )
run-all-tests
[ keys test-all-vocabs-file to-file ]
@@ -29,7 +43,7 @@ IN: mason.test
: do-all ( -- )
".." [
bootstrap-time get boot-time-file to-file
- [ do-load ] benchmark load-time-file to-file
+ [ do-load do-compile-errors ] benchmark load-time-file to-file
[ generate-help ] benchmark html-help-time-file to-file
[ do-tests ] benchmark test-time-file to-file
[ do-help-lint ] benchmark help-lint-time-file to-file
From bb8df5c0c9c2a828f930963001a6ce8cf0b51f5c Mon Sep 17 00:00:00 2001
From: "Jose A. Ortega Ruiz" <jao@gnu.org>
Date: Sun, 16 Nov 2008 22:10:19 +0100
Subject: [PATCH 133/157] Cosmetic changes: factor-- prefix for internal
symbols, sectioning with ^L, header comments.
---
misc/factor.el | 237 ++++++++++++++++++++++++++-----------------------
1 file changed, 124 insertions(+), 113 deletions(-)
diff --git a/misc/factor.el b/misc/factor.el
index 2d222187e4..393ed26ae0 100644
--- a/misc/factor.el
+++ b/misc/factor.el
@@ -1,25 +1,42 @@
-;; Eduardo Cavazos - wayo.cavazos@gmail.com
+;;; factor.el --- Interacting with Factor within emacs
+;;
+;; Authors: Eduardo Cavazos <wayo.cavazos@gmail.com>
+;; Jose A Ortega Ruiz <jao@gnu.org>
+;; Keywords: languages
+
+;;; Commentary:
+
+;;; Quick setup:
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Add these lines to your .emacs file:
-
-;; (load-file "/scratch/repos/Factor/misc/factor.el")
-;; (setq factor-binary "/scratch/repos/Factor/factor")
-;; (setq factor-image "/scratch/repos/Factor/factor.image")
-
+;;
+;; (load-file "/scratch/repos/Factor/misc/factor.el")
+;; (setq factor-binary "/scratch/repos/Factor/factor")
+;; (setq factor-image "/scratch/repos/Factor/factor.image")
+;;
;; Of course, you'll have to edit the directory paths for your system
-;; accordingly.
-
+;; accordingly. Alternatively, put this file in your load-path and use
+;;
+;; (require 'factor)
+;;
+;; instead of load-file.
+;;
;; That's all you have to do to "install" factor.el on your
;; system. Whenever you edit a factor file, Emacs will know to switch
;; to Factor mode.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; For further customization options,
+;; M-x customize-group RET factor
+;;
+;; To start a Factor listener inside Emacs,
+;; M-x run-factor
-;; M-x run-factor === Start a Factor listener inside Emacs
+;;; Requirements:
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Customization
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(require 'font-lock)
+(require 'comint)
+
+;;; Customization:
(defgroup factor nil
"Factor mode"
@@ -37,9 +54,19 @@ value from the existing code in the buffer."
:type 'integer
:group 'factor)
+(defcustom factor-binary "~/factor/factor"
+ "Full path to the factor executable to use when starting a listener."
+ :type '(file :must-match t)
+ :group 'factor)
+
+(defcustom factor-image "~/factor/factor.image"
+ "Full path to the factor image to use when starting a listener."
+ :type '(file :must-match t)
+ :group 'factor)
+
(defcustom factor-display-compilation-output t
"Display the REPL buffer before compiling files."
- :type '(choice (const :tag "Enable" t) (const :tag "Disable" nil))
+ :type 'boolean
:group 'factor)
(defcustom factor-mode-hook nil
@@ -47,59 +74,6 @@ value from the existing code in the buffer."
:type 'hook
:group 'factor)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; factor-mode syntax
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defvar factor-mode-syntax-table nil
- "Syntax table used while in Factor mode.")
-
-(if factor-mode-syntax-table
- ()
- (let ((i 0))
- (setq factor-mode-syntax-table (make-syntax-table))
-
- ;; Default is atom-constituent
- (while (< i 256)
- (modify-syntax-entry i "_ " factor-mode-syntax-table)
- (setq i (1+ i)))
-
- ;; Word components.
- (setq i ?0)
- (while (<= i ?9)
- (modify-syntax-entry i "w " factor-mode-syntax-table)
- (setq i (1+ i)))
- (setq i ?A)
- (while (<= i ?Z)
- (modify-syntax-entry i "w " factor-mode-syntax-table)
- (setq i (1+ i)))
- (setq i ?a)
- (while (<= i ?z)
- (modify-syntax-entry i "w " factor-mode-syntax-table)
- (setq i (1+ i)))
-
- ;; Whitespace
- (modify-syntax-entry ?\t " " factor-mode-syntax-table)
- (modify-syntax-entry ?\n ">" factor-mode-syntax-table)
- (modify-syntax-entry ?\f " " factor-mode-syntax-table)
- (modify-syntax-entry ?\r " " factor-mode-syntax-table)
- (modify-syntax-entry ? " " factor-mode-syntax-table)
-
- (modify-syntax-entry ?\[ "(] " factor-mode-syntax-table)
- (modify-syntax-entry ?\] ")[ " factor-mode-syntax-table)
- (modify-syntax-entry ?{ "(} " factor-mode-syntax-table)
- (modify-syntax-entry ?} "){ " factor-mode-syntax-table)
-
- (modify-syntax-entry ?\( "()" factor-mode-syntax-table)
- (modify-syntax-entry ?\) ")(" factor-mode-syntax-table)
- (modify-syntax-entry ?\" "\" " factor-mode-syntax-table)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; factor-mode font lock
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(require 'font-lock)
-
(defgroup factor-faces nil
"Faces used in Factor mode"
:group 'factor
@@ -143,6 +117,9 @@ value from the existing code in the buffer."
"Face for parsing words."
:group 'factor-faces)
+
+;;; Factor mode font lock:
+
(defconst factor--parsing-words
'("{" "}" "^:" "^::" ";" "<<" "<PRIVATE" ">>"
"BIN:" "BV{" "B{" "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CS{" "C{"
@@ -191,16 +168,57 @@ value from the existing code in the buffer."
(,factor--regex-type-definition 2 'factor-font-lock-type-definition)
(,factor--regex-symbol-definition 2 'factor-font-lock-symbol-definition)
(,factor--regex-using-line 1 'factor-font-lock-vocabulary-name)
- (,factor--regex-use-line 1 'factor-font-lock-vocabulary-name)))
+ (,factor--regex-use-line 1 'factor-font-lock-vocabulary-name))
+ "Font lock keywords definition for Factor mode.")
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; factor-mode commands
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Factor mode syntax:
-(require 'comint)
+(defvar factor-mode-syntax-table nil
+ "Syntax table used while in Factor mode.")
-(defvar factor-binary "~/factor/factor")
-(defvar factor-image "~/factor/factor.image")
+(if factor-mode-syntax-table
+ ()
+ (let ((i 0))
+ (setq factor-mode-syntax-table (make-syntax-table))
+
+ ;; Default is atom-constituent
+ (while (< i 256)
+ (modify-syntax-entry i "_ " factor-mode-syntax-table)
+ (setq i (1+ i)))
+
+ ;; Word components.
+ (setq i ?0)
+ (while (<= i ?9)
+ (modify-syntax-entry i "w " factor-mode-syntax-table)
+ (setq i (1+ i)))
+ (setq i ?A)
+ (while (<= i ?Z)
+ (modify-syntax-entry i "w " factor-mode-syntax-table)
+ (setq i (1+ i)))
+ (setq i ?a)
+ (while (<= i ?z)
+ (modify-syntax-entry i "w " factor-mode-syntax-table)
+ (setq i (1+ i)))
+
+ ;; Whitespace
+ (modify-syntax-entry ?\t " " factor-mode-syntax-table)
+ (modify-syntax-entry ?\n ">" factor-mode-syntax-table)
+ (modify-syntax-entry ?\f " " factor-mode-syntax-table)
+ (modify-syntax-entry ?\r " " factor-mode-syntax-table)
+ (modify-syntax-entry ? " " factor-mode-syntax-table)
+
+ (modify-syntax-entry ?\[ "(] " factor-mode-syntax-table)
+ (modify-syntax-entry ?\] ")[ " factor-mode-syntax-table)
+ (modify-syntax-entry ?{ "(} " factor-mode-syntax-table)
+ (modify-syntax-entry ?} "){ " factor-mode-syntax-table)
+
+ (modify-syntax-entry ?\( "()" factor-mode-syntax-table)
+ (modify-syntax-entry ?\) ")(" factor-mode-syntax-table)
+ (modify-syntax-entry ?\" "\" " factor-mode-syntax-table)))
+
+
+;;; Factor mode commands:
(defun factor-telnet-to-port (port)
(interactive "nPort: ")
@@ -231,11 +249,6 @@ value from the existing code in the buffer."
(unless (get-buffer-window (current-buffer) t)
(display-buffer (current-buffer) t))))
-;; (defun factor-send-region (start end)
-;; (interactive "r")
-;; (comint-send-region "*factor*" start end)
-;; (comint-send-string "*factor*" "\n"))
-
(defun factor-send-string (str)
(let ((n (length (split-string str "\n"))))
(save-excursion
@@ -288,7 +301,8 @@ value from the existing code in the buffer."
(beginning-of-line)
(insert "! "))
-(defvar factor-mode-map (make-sparse-keymap))
+(defvar factor-mode-map (make-sparse-keymap)
+ "Key map used by Factor mode.")
(define-key factor-mode-map "\C-c\C-f" 'factor-run-file)
(define-key factor-mode-map "\C-c\C-r" 'factor-send-region)
@@ -300,39 +314,39 @@ value from the existing code in the buffer."
(define-key factor-mode-map [return] 'newline-and-indent)
(define-key factor-mode-map [tab] 'indent-for-tab-command)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; factor-mode indentation
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defconst factor-word-starting-keywords
- '("" ":" "TUPLE" "MACRO" "MACRO:" "M"))
-
-(defmacro factor-word-start-re (keywords)
- `(format
- "^\\(%s\\): "
- (mapconcat 'identity ,keywords "\\|")))
+
+;;; Factor mode indentation:
(defvar factor-indent-width factor-default-indent-width
"Indentation width in factor buffers. A local variable.")
(make-variable-buffer-local 'factor-indent-width)
+(defconst factor--regexp-word-start
+ (let ((sws '("" ":" "TUPLE" "MACRO" "MACRO:" "M")))
+ (format "^\\(%s\\): " (mapconcat 'identity sws "\\|"))))
+
(defun factor--guess-indent-width ()
"Chooses an indentation value from existing code."
- (let ((word-def (factor-word-start-re factor-word-starting-keywords))
- (word-cont "^ +[^ ]")
+ (let ((word-cont "^ +[^ ]")
(iw))
(save-excursion
(beginning-of-buffer)
(while (not iw)
- (if (not (re-search-forward word-def nil t))
+ (if (not (re-search-forward factor--regexp-word-start nil t))
(setq iw factor-default-indent-width)
(forward-line)
(when (looking-at word-cont)
(setq iw (current-indentation))))))
iw))
-(defun factor-calculate-indentation ()
+(defun factor--brackets-depth ()
+ "Returns number of brackets, not closed on previous lines."
+ (syntax-ppss-depth
+ (save-excursion
+ (syntax-ppss (line-beginning-position)))))
+
+(defun factor--calculate-indentation ()
"Calculate Factor indentation for line at point."
(let ((not-indented t)
(cur-indent 0))
@@ -344,11 +358,11 @@ value from the existing code in the buffer."
(while not-indented
;; Check that we are inside open brackets
(save-excursion
- (let ((cur-depth (factor-brackets-depth)))
+ (let ((cur-depth (factor--brackets-depth)))
(forward-line -1)
(setq cur-indent (+ (current-indentation)
(* factor-indent-width
- (- cur-depth (factor-brackets-depth)))))
+ (- cur-depth (factor--brackets-depth)))))
(setq not-indented nil)))
(forward-line -1)
;; Check that we are after the end of previous word
@@ -357,8 +371,7 @@ value from the existing code in the buffer."
(setq cur-indent (- (current-indentation) factor-indent-width))
(setq not-indented nil))
;; Check that we are after the start of word
- (if (looking-at (factor-word-start-re factor-word-starting-keywords))
-; (if (looking-at "^[A-Z:]*: ")
+ (if (looking-at factor--regexp-word-start)
(progn
(message "inword")
(setq cur-indent (+ (current-indentation) factor-indent-width))
@@ -367,15 +380,9 @@ value from the existing code in the buffer."
(setq not-indented nil))))))))
cur-indent))
-(defun factor-brackets-depth ()
- "Returns number of brackets, not closed on previous lines."
- (syntax-ppss-depth
- (save-excursion
- (syntax-ppss (line-beginning-position)))))
-
(defun factor-indent-line ()
"Indent current line as Factor code"
- (let ((target (factor-calculate-indentation))
+ (let ((target (factor--calculate-indentation))
(pos (- (point-max) (point))))
(if (= target (current-indentation))
(if (< (current-column) (current-indentation))
@@ -386,10 +393,10 @@ value from the existing code in the buffer."
(if (> (- (point-max) pos) (point))
(goto-char (- (point-max) pos))))))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; factor-mode
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Factor mode:
+;;;###autoload
(defun factor-mode ()
"A mode for editing programs written in the Factor programming language.
\\{factor-mode-map}"
@@ -410,9 +417,8 @@ value from the existing code in the buffer."
(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; factor-listener-mode
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Factor listener mode
(define-derived-mode factor-listener-mode comint-mode "Factor Listener")
@@ -429,3 +435,8 @@ value from the existing code in the buffer."
(defun factor-refresh-all ()
(interactive)
(comint-send-string "*factor*" "refresh-all\n"))
+
+
+
+(provide 'factor)
+;;; factor.el ends here
From fbe29ceca826a7c62200ee3b79f51982fa1aaf8a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 15:31:17 -0600
Subject: [PATCH 134/157] format-table should not be private since
ui.gadgets.grids uses it
---
core/io/streams/string/string.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor
index 184b5e1c15..10d8f7d947 100644
--- a/core/io/streams/string/string.factor
+++ b/core/io/streams/string/string.factor
@@ -26,12 +26,12 @@ M: null-encoding decode-char drop stream-read1 ;
: map-last ( seq quot -- seq )
>r dup length <reversed> [ zero? ] r> compose 2map ; inline
+PRIVATE>
+
: format-table ( table -- seq )
flip [ format-column ] map-last
flip [ " " join ] map ;
-PRIVATE>
-
M: growable dispose drop ;
M: growable stream-write1 push ;
From 78161aa2b3143009c59ffd2b071db2fc6907eff3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 15:31:31 -0600
Subject: [PATCH 135/157] Fix bug in do-compile-errors
---
extra/mason/test/test.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/mason/test/test.factor b/extra/mason/test/test.factor
index 760b51617d..0206df7db9 100644
--- a/extra/mason/test/test.factor
+++ b/extra/mason/test/test.factor
@@ -16,7 +16,7 @@ GENERIC: word-vocabulary ( word -- vocabulary )
M: word word-vocabulary vocabulary>> ;
-M: method-body word-vocabulary "method-generic" word-prop ;
+M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ;
: do-compile-errors ( -- )
compiler-errors-file utf8 [
From 6d28ecc46b6b647775c3431fa05e3b64cf9e6c4b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 15:39:30 -0600
Subject: [PATCH 136/157] Forgot to add call to upload-help
---
extra/mason/build/build.factor | 1 +
1 file changed, 1 insertion(+)
diff --git a/extra/mason/build/build.factor b/extra/mason/build/build.factor
index 8b8befce34..f253529950 100644
--- a/extra/mason/build/build.factor
+++ b/extra/mason/build/build.factor
@@ -23,6 +23,7 @@ IN: mason.build
clone-builds-factor
record-id
build-child
+ upload-help
release
email-report
cleanup ;
From a85be4658cab892747096e5e87e750b58bd5e8ea Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Sun, 16 Nov 2008 15:50:48 -0600
Subject: [PATCH 137/157] fix compile errors
---
extra/hardware-info/macosx/macosx.factor | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/extra/hardware-info/macosx/macosx.factor b/extra/hardware-info/macosx/macosx.factor
index fe1fd72a21..e3c604f2fd 100644
--- a/extra/hardware-info/macosx/macosx.factor
+++ b/extra/hardware-info/macosx/macosx.factor
@@ -12,11 +12,11 @@ FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, voi
: make-int-array ( seq -- byte-array )
[ <int> ] map concat ;
-: (sysctl-query) ( name namelen oldp oldlenp -- oldp error/f )
- over >r f 0 sysctl io-error r> ;
+: (sysctl-query) ( name namelen oldp oldlenp -- oldp )
+ over [ f 0 sysctl io-error ] dip ;
: sysctl-query ( seq n -- byte-array )
- >r [ make-int-array ] [ length ] bi r>
+ [ [ make-int-array ] [ length ] bi ] dip
[ <byte-array> ] [ <uint> ] bi (sysctl-query) ;
: sysctl-query-string ( seq -- n )
From c471edba59fd88a2bff1cff5f97f0c061ad72ae0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 15:51:10 -0600
Subject: [PATCH 138/157] Fix load error
---
extra/mason/build/build.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/extra/mason/build/build.factor b/extra/mason/build/build.factor
index f253529950..35070d8902 100644
--- a/extra/mason/build/build.factor
+++ b/extra/mason/build/build.factor
@@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io.launcher io.encodings.utf8 prettyprint arrays
calendar namespaces mason.common mason.child
-mason.release mason.report mason.email mason.cleanup ;
+mason.release mason.report mason.email mason.cleanup
+mason.help ;
IN: mason.build
: create-build-dir ( -- )
From bd2d78b6b19b3ba8d336d98000df2829f7cc42e8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 16:19:18 -0600
Subject: [PATCH 139/157] Disable referrer checking by default since adblock
doesn't send it for some lame reason
---
basis/furnace/alloy/alloy.factor | 4 +---
1 file changed, 1 insertion(+), 3 deletions(-)
diff --git a/basis/furnace/alloy/alloy.factor b/basis/furnace/alloy/alloy.factor
index 128ec448b7..0fe80427b9 100644
--- a/basis/furnace/alloy/alloy.factor
+++ b/basis/furnace/alloy/alloy.factor
@@ -4,7 +4,6 @@ USING: kernel sequences db.tuples alarms calendar db fry
furnace.db
furnace.cache
furnace.asides
-furnace.referrer
furnace.sessions
furnace.conversations
furnace.auth.providers
@@ -24,8 +23,7 @@ IN: furnace.alloy
<conversations>
<sessions>
] dip
- <db-persistence>
- <check-form-submissions> ;
+ <db-persistence> ;
: start-expiring ( db -- )
'[
From f2d34b6d6ec4c5def9649e046cec8e6ad90f05d3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 16:21:25 -0600
Subject: [PATCH 140/157] Only upload help if buld is clean
---
extra/mason/help/help.factor | 5 ++++-
1 file changed, 4 insertions(+), 1 deletion(-)
diff --git a/extra/mason/help/help.factor b/extra/mason/help/help.factor
index 1e3e1509c9..c9ca50f0c2 100644
--- a/extra/mason/help/help.factor
+++ b/extra/mason/help/help.factor
@@ -16,8 +16,11 @@ IN: mason.help
help-directory get "/docs.tar.gz" append
upload-safely ;
-: upload-help ( -- )
+: (upload-help) ( -- )
upload-help? get [
make-help-archive
upload-help-archive
] when ;
+
+: upload-help ( -- )
+ status get status-clean eq? [ (upload-help) ] when ;
From e6fbd4f84fc91eb8cabce43eb060aeaf7c0092e8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@finkelstein.stack-effects.info>
Date: Sun, 16 Nov 2008 16:59:25 -0600
Subject: [PATCH 141/157] fix compile errors
---
extra/html/parser/analyzer/analyzer.factor | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor
index 8d7a92b0d9..a18bb31874 100755
--- a/extra/html/parser/analyzer/analyzer.factor
+++ b/extra/html/parser/analyzer/analyzer.factor
@@ -60,13 +60,13 @@ TUPLE: link attributes clickable ;
[ [ [ blank? ] trim ] change-text ] when
] map ;
-: find-by-id ( vector id -- vector' )
+: find-by-id ( vector id -- vector' elt/f )
'[ attributes>> "id" at _ = ] find ;
-: find-by-class ( vector id -- vector' )
+: find-by-class ( vector id -- vector' elt/f )
'[ attributes>> "class" at _ = ] find ;
-: find-by-name ( vector string -- vector )
+: find-by-name ( vector string -- vector elt/f )
>lower '[ name>> _ = ] find ;
: find-by-id-between ( vector string -- vector' )
@@ -83,7 +83,7 @@ TUPLE: link attributes clickable ;
[ attributes>> "id" swap at _ = ] bi and
] dupd find find-between* ;
-: find-by-attribute-key ( vector key -- vector' )
+: find-by-attribute-key ( vector key -- vector' elt/? )
>lower
[ attributes>> at _ = ] filter sift ;
From e030d5bdfb5ba6c46899d8e9fbdfddca07588af3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 17:18:10 -0600
Subject: [PATCH 142/157] Move odbc to unmtainained: compile errors
---
{extra => unmaintained}/odbc/authors.txt | 0
{extra => unmaintained}/odbc/odbc-docs.factor | 0
{extra => unmaintained}/odbc/odbc.factor | 0
{extra => unmaintained}/odbc/summary.txt | 0
{extra => unmaintained}/odbc/tags.txt | 0
5 files changed, 0 insertions(+), 0 deletions(-)
rename {extra => unmaintained}/odbc/authors.txt (100%)
rename {extra => unmaintained}/odbc/odbc-docs.factor (100%)
rename {extra => unmaintained}/odbc/odbc.factor (100%)
rename {extra => unmaintained}/odbc/summary.txt (100%)
rename {extra => unmaintained}/odbc/tags.txt (100%)
diff --git a/extra/odbc/authors.txt b/unmaintained/odbc/authors.txt
similarity index 100%
rename from extra/odbc/authors.txt
rename to unmaintained/odbc/authors.txt
diff --git a/extra/odbc/odbc-docs.factor b/unmaintained/odbc/odbc-docs.factor
similarity index 100%
rename from extra/odbc/odbc-docs.factor
rename to unmaintained/odbc/odbc-docs.factor
diff --git a/extra/odbc/odbc.factor b/unmaintained/odbc/odbc.factor
similarity index 100%
rename from extra/odbc/odbc.factor
rename to unmaintained/odbc/odbc.factor
diff --git a/extra/odbc/summary.txt b/unmaintained/odbc/summary.txt
similarity index 100%
rename from extra/odbc/summary.txt
rename to unmaintained/odbc/summary.txt
diff --git a/extra/odbc/tags.txt b/unmaintained/odbc/tags.txt
similarity index 100%
rename from extra/odbc/tags.txt
rename to unmaintained/odbc/tags.txt
From 4feecbd23e880e0b92a405f20ee80e9cc568fdc3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 17:20:02 -0600
Subject: [PATCH 143/157] More more stuff to unmaintained because of compile
errors
---
{extra => unmaintained}/factory/authors.txt | 0
{extra => unmaintained}/factory/commands/authors.txt | 0
{extra => unmaintained}/factory/commands/commands.factor | 0
{extra => unmaintained}/factory/factory-menus | 0
{extra => unmaintained}/factory/factory-rc | 0
{extra => unmaintained}/factory/factory.factor | 0
{extra => unmaintained}/factory/load/authors.txt | 0
{extra => unmaintained}/factory/load/load.factor | 0
{extra => unmaintained}/factory/summary.txt | 0
{extra => unmaintained}/factory/tags.txt | 0
{extra => unmaintained}/mortar/authors.txt | 0
{extra => unmaintained}/mortar/mortar.factor | 0
{extra => unmaintained}/mortar/sugar/sugar.factor | 0
{extra => unmaintained}/mortar/tags.txt | 0
{extra/ui/gadgets => unmaintained}/tiling/tiling.factor | 0
{extra => unmaintained}/x/authors.txt | 0
{extra => unmaintained}/x/font/authors.txt | 0
{extra => unmaintained}/x/font/font.factor | 0
{extra => unmaintained}/x/gc/authors.txt | 0
{extra => unmaintained}/x/gc/gc.factor | 0
{extra => unmaintained}/x/keysym-table/authors.txt | 0
{extra => unmaintained}/x/keysym-table/keysym-table.factor | 0
{extra => unmaintained}/x/pen/authors.txt | 0
{extra => unmaintained}/x/pen/pen.factor | 0
{extra => unmaintained}/x/widgets/authors.txt | 0
{extra => unmaintained}/x/widgets/button/authors.txt | 0
{extra => unmaintained}/x/widgets/button/button.factor | 0
{extra => unmaintained}/x/widgets/keymenu/authors.txt | 0
{extra => unmaintained}/x/widgets/keymenu/keymenu.factor | 0
{extra => unmaintained}/x/widgets/label/authors.txt | 0
{extra => unmaintained}/x/widgets/label/label.factor | 0
{extra => unmaintained}/x/widgets/widgets.factor | 0
{extra => unmaintained}/x/widgets/wm/child/authors.txt | 0
{extra => unmaintained}/x/widgets/wm/child/child.factor | 0
{extra => unmaintained}/x/widgets/wm/frame/authors.txt | 0
{extra => unmaintained}/x/widgets/wm/frame/drag/authors.txt | 0
{extra => unmaintained}/x/widgets/wm/frame/drag/drag.factor | 0
{extra => unmaintained}/x/widgets/wm/frame/drag/move/authors.txt | 0
{extra => unmaintained}/x/widgets/wm/frame/drag/move/move.factor | 0
{extra => unmaintained}/x/widgets/wm/frame/drag/size/authors.txt | 0
{extra => unmaintained}/x/widgets/wm/frame/drag/size/size.factor | 0
{extra => unmaintained}/x/widgets/wm/frame/frame.factor | 0
{extra => unmaintained}/x/widgets/wm/menu/authors.txt | 0
{extra => unmaintained}/x/widgets/wm/menu/menu.factor | 0
{extra => unmaintained}/x/widgets/wm/root/authors.txt | 0
{extra => unmaintained}/x/widgets/wm/root/root.factor | 0
.../x/widgets/wm/unmapped-frames-menu/authors.txt | 0
.../x/widgets/wm/unmapped-frames-menu/unmapped-frames-menu.factor | 0
{extra => unmaintained}/x/widgets/wm/workspace/authors.txt | 0
{extra => unmaintained}/x/widgets/wm/workspace/workspace.factor | 0
{extra => unmaintained}/x/x.factor | 0
51 files changed, 0 insertions(+), 0 deletions(-)
rename {extra => unmaintained}/factory/authors.txt (100%)
rename {extra => unmaintained}/factory/commands/authors.txt (100%)
rename {extra => unmaintained}/factory/commands/commands.factor (100%)
rename {extra => unmaintained}/factory/factory-menus (100%)
rename {extra => unmaintained}/factory/factory-rc (100%)
rename {extra => unmaintained}/factory/factory.factor (100%)
rename {extra => unmaintained}/factory/load/authors.txt (100%)
rename {extra => unmaintained}/factory/load/load.factor (100%)
rename {extra => unmaintained}/factory/summary.txt (100%)
rename {extra => unmaintained}/factory/tags.txt (100%)
rename {extra => unmaintained}/mortar/authors.txt (100%)
rename {extra => unmaintained}/mortar/mortar.factor (100%)
rename {extra => unmaintained}/mortar/sugar/sugar.factor (100%)
rename {extra => unmaintained}/mortar/tags.txt (100%)
rename {extra/ui/gadgets => unmaintained}/tiling/tiling.factor (100%)
rename {extra => unmaintained}/x/authors.txt (100%)
rename {extra => unmaintained}/x/font/authors.txt (100%)
rename {extra => unmaintained}/x/font/font.factor (100%)
rename {extra => unmaintained}/x/gc/authors.txt (100%)
rename {extra => unmaintained}/x/gc/gc.factor (100%)
rename {extra => unmaintained}/x/keysym-table/authors.txt (100%)
rename {extra => unmaintained}/x/keysym-table/keysym-table.factor (100%)
rename {extra => unmaintained}/x/pen/authors.txt (100%)
rename {extra => unmaintained}/x/pen/pen.factor (100%)
rename {extra => unmaintained}/x/widgets/authors.txt (100%)
rename {extra => unmaintained}/x/widgets/button/authors.txt (100%)
rename {extra => unmaintained}/x/widgets/button/button.factor (100%)
rename {extra => unmaintained}/x/widgets/keymenu/authors.txt (100%)
rename {extra => unmaintained}/x/widgets/keymenu/keymenu.factor (100%)
rename {extra => unmaintained}/x/widgets/label/authors.txt (100%)
rename {extra => unmaintained}/x/widgets/label/label.factor (100%)
rename {extra => unmaintained}/x/widgets/widgets.factor (100%)
rename {extra => unmaintained}/x/widgets/wm/child/authors.txt (100%)
rename {extra => unmaintained}/x/widgets/wm/child/child.factor (100%)
rename {extra => unmaintained}/x/widgets/wm/frame/authors.txt (100%)
rename {extra => unmaintained}/x/widgets/wm/frame/drag/authors.txt (100%)
rename {extra => unmaintained}/x/widgets/wm/frame/drag/drag.factor (100%)
rename {extra => unmaintained}/x/widgets/wm/frame/drag/move/authors.txt (100%)
rename {extra => unmaintained}/x/widgets/wm/frame/drag/move/move.factor (100%)
rename {extra => unmaintained}/x/widgets/wm/frame/drag/size/authors.txt (100%)
rename {extra => unmaintained}/x/widgets/wm/frame/drag/size/size.factor (100%)
rename {extra => unmaintained}/x/widgets/wm/frame/frame.factor (100%)
rename {extra => unmaintained}/x/widgets/wm/menu/authors.txt (100%)
rename {extra => unmaintained}/x/widgets/wm/menu/menu.factor (100%)
rename {extra => unmaintained}/x/widgets/wm/root/authors.txt (100%)
rename {extra => unmaintained}/x/widgets/wm/root/root.factor (100%)
rename {extra => unmaintained}/x/widgets/wm/unmapped-frames-menu/authors.txt (100%)
rename {extra => unmaintained}/x/widgets/wm/unmapped-frames-menu/unmapped-frames-menu.factor (100%)
rename {extra => unmaintained}/x/widgets/wm/workspace/authors.txt (100%)
rename {extra => unmaintained}/x/widgets/wm/workspace/workspace.factor (100%)
rename {extra => unmaintained}/x/x.factor (100%)
diff --git a/extra/factory/authors.txt b/unmaintained/factory/authors.txt
similarity index 100%
rename from extra/factory/authors.txt
rename to unmaintained/factory/authors.txt
diff --git a/extra/factory/commands/authors.txt b/unmaintained/factory/commands/authors.txt
similarity index 100%
rename from extra/factory/commands/authors.txt
rename to unmaintained/factory/commands/authors.txt
diff --git a/extra/factory/commands/commands.factor b/unmaintained/factory/commands/commands.factor
similarity index 100%
rename from extra/factory/commands/commands.factor
rename to unmaintained/factory/commands/commands.factor
diff --git a/extra/factory/factory-menus b/unmaintained/factory/factory-menus
similarity index 100%
rename from extra/factory/factory-menus
rename to unmaintained/factory/factory-menus
diff --git a/extra/factory/factory-rc b/unmaintained/factory/factory-rc
similarity index 100%
rename from extra/factory/factory-rc
rename to unmaintained/factory/factory-rc
diff --git a/extra/factory/factory.factor b/unmaintained/factory/factory.factor
similarity index 100%
rename from extra/factory/factory.factor
rename to unmaintained/factory/factory.factor
diff --git a/extra/factory/load/authors.txt b/unmaintained/factory/load/authors.txt
similarity index 100%
rename from extra/factory/load/authors.txt
rename to unmaintained/factory/load/authors.txt
diff --git a/extra/factory/load/load.factor b/unmaintained/factory/load/load.factor
similarity index 100%
rename from extra/factory/load/load.factor
rename to unmaintained/factory/load/load.factor
diff --git a/extra/factory/summary.txt b/unmaintained/factory/summary.txt
similarity index 100%
rename from extra/factory/summary.txt
rename to unmaintained/factory/summary.txt
diff --git a/extra/factory/tags.txt b/unmaintained/factory/tags.txt
similarity index 100%
rename from extra/factory/tags.txt
rename to unmaintained/factory/tags.txt
diff --git a/extra/mortar/authors.txt b/unmaintained/mortar/authors.txt
similarity index 100%
rename from extra/mortar/authors.txt
rename to unmaintained/mortar/authors.txt
diff --git a/extra/mortar/mortar.factor b/unmaintained/mortar/mortar.factor
similarity index 100%
rename from extra/mortar/mortar.factor
rename to unmaintained/mortar/mortar.factor
diff --git a/extra/mortar/sugar/sugar.factor b/unmaintained/mortar/sugar/sugar.factor
similarity index 100%
rename from extra/mortar/sugar/sugar.factor
rename to unmaintained/mortar/sugar/sugar.factor
diff --git a/extra/mortar/tags.txt b/unmaintained/mortar/tags.txt
similarity index 100%
rename from extra/mortar/tags.txt
rename to unmaintained/mortar/tags.txt
diff --git a/extra/ui/gadgets/tiling/tiling.factor b/unmaintained/tiling/tiling.factor
similarity index 100%
rename from extra/ui/gadgets/tiling/tiling.factor
rename to unmaintained/tiling/tiling.factor
diff --git a/extra/x/authors.txt b/unmaintained/x/authors.txt
similarity index 100%
rename from extra/x/authors.txt
rename to unmaintained/x/authors.txt
diff --git a/extra/x/font/authors.txt b/unmaintained/x/font/authors.txt
similarity index 100%
rename from extra/x/font/authors.txt
rename to unmaintained/x/font/authors.txt
diff --git a/extra/x/font/font.factor b/unmaintained/x/font/font.factor
similarity index 100%
rename from extra/x/font/font.factor
rename to unmaintained/x/font/font.factor
diff --git a/extra/x/gc/authors.txt b/unmaintained/x/gc/authors.txt
similarity index 100%
rename from extra/x/gc/authors.txt
rename to unmaintained/x/gc/authors.txt
diff --git a/extra/x/gc/gc.factor b/unmaintained/x/gc/gc.factor
similarity index 100%
rename from extra/x/gc/gc.factor
rename to unmaintained/x/gc/gc.factor
diff --git a/extra/x/keysym-table/authors.txt b/unmaintained/x/keysym-table/authors.txt
similarity index 100%
rename from extra/x/keysym-table/authors.txt
rename to unmaintained/x/keysym-table/authors.txt
diff --git a/extra/x/keysym-table/keysym-table.factor b/unmaintained/x/keysym-table/keysym-table.factor
similarity index 100%
rename from extra/x/keysym-table/keysym-table.factor
rename to unmaintained/x/keysym-table/keysym-table.factor
diff --git a/extra/x/pen/authors.txt b/unmaintained/x/pen/authors.txt
similarity index 100%
rename from extra/x/pen/authors.txt
rename to unmaintained/x/pen/authors.txt
diff --git a/extra/x/pen/pen.factor b/unmaintained/x/pen/pen.factor
similarity index 100%
rename from extra/x/pen/pen.factor
rename to unmaintained/x/pen/pen.factor
diff --git a/extra/x/widgets/authors.txt b/unmaintained/x/widgets/authors.txt
similarity index 100%
rename from extra/x/widgets/authors.txt
rename to unmaintained/x/widgets/authors.txt
diff --git a/extra/x/widgets/button/authors.txt b/unmaintained/x/widgets/button/authors.txt
similarity index 100%
rename from extra/x/widgets/button/authors.txt
rename to unmaintained/x/widgets/button/authors.txt
diff --git a/extra/x/widgets/button/button.factor b/unmaintained/x/widgets/button/button.factor
similarity index 100%
rename from extra/x/widgets/button/button.factor
rename to unmaintained/x/widgets/button/button.factor
diff --git a/extra/x/widgets/keymenu/authors.txt b/unmaintained/x/widgets/keymenu/authors.txt
similarity index 100%
rename from extra/x/widgets/keymenu/authors.txt
rename to unmaintained/x/widgets/keymenu/authors.txt
diff --git a/extra/x/widgets/keymenu/keymenu.factor b/unmaintained/x/widgets/keymenu/keymenu.factor
similarity index 100%
rename from extra/x/widgets/keymenu/keymenu.factor
rename to unmaintained/x/widgets/keymenu/keymenu.factor
diff --git a/extra/x/widgets/label/authors.txt b/unmaintained/x/widgets/label/authors.txt
similarity index 100%
rename from extra/x/widgets/label/authors.txt
rename to unmaintained/x/widgets/label/authors.txt
diff --git a/extra/x/widgets/label/label.factor b/unmaintained/x/widgets/label/label.factor
similarity index 100%
rename from extra/x/widgets/label/label.factor
rename to unmaintained/x/widgets/label/label.factor
diff --git a/extra/x/widgets/widgets.factor b/unmaintained/x/widgets/widgets.factor
similarity index 100%
rename from extra/x/widgets/widgets.factor
rename to unmaintained/x/widgets/widgets.factor
diff --git a/extra/x/widgets/wm/child/authors.txt b/unmaintained/x/widgets/wm/child/authors.txt
similarity index 100%
rename from extra/x/widgets/wm/child/authors.txt
rename to unmaintained/x/widgets/wm/child/authors.txt
diff --git a/extra/x/widgets/wm/child/child.factor b/unmaintained/x/widgets/wm/child/child.factor
similarity index 100%
rename from extra/x/widgets/wm/child/child.factor
rename to unmaintained/x/widgets/wm/child/child.factor
diff --git a/extra/x/widgets/wm/frame/authors.txt b/unmaintained/x/widgets/wm/frame/authors.txt
similarity index 100%
rename from extra/x/widgets/wm/frame/authors.txt
rename to unmaintained/x/widgets/wm/frame/authors.txt
diff --git a/extra/x/widgets/wm/frame/drag/authors.txt b/unmaintained/x/widgets/wm/frame/drag/authors.txt
similarity index 100%
rename from extra/x/widgets/wm/frame/drag/authors.txt
rename to unmaintained/x/widgets/wm/frame/drag/authors.txt
diff --git a/extra/x/widgets/wm/frame/drag/drag.factor b/unmaintained/x/widgets/wm/frame/drag/drag.factor
similarity index 100%
rename from extra/x/widgets/wm/frame/drag/drag.factor
rename to unmaintained/x/widgets/wm/frame/drag/drag.factor
diff --git a/extra/x/widgets/wm/frame/drag/move/authors.txt b/unmaintained/x/widgets/wm/frame/drag/move/authors.txt
similarity index 100%
rename from extra/x/widgets/wm/frame/drag/move/authors.txt
rename to unmaintained/x/widgets/wm/frame/drag/move/authors.txt
diff --git a/extra/x/widgets/wm/frame/drag/move/move.factor b/unmaintained/x/widgets/wm/frame/drag/move/move.factor
similarity index 100%
rename from extra/x/widgets/wm/frame/drag/move/move.factor
rename to unmaintained/x/widgets/wm/frame/drag/move/move.factor
diff --git a/extra/x/widgets/wm/frame/drag/size/authors.txt b/unmaintained/x/widgets/wm/frame/drag/size/authors.txt
similarity index 100%
rename from extra/x/widgets/wm/frame/drag/size/authors.txt
rename to unmaintained/x/widgets/wm/frame/drag/size/authors.txt
diff --git a/extra/x/widgets/wm/frame/drag/size/size.factor b/unmaintained/x/widgets/wm/frame/drag/size/size.factor
similarity index 100%
rename from extra/x/widgets/wm/frame/drag/size/size.factor
rename to unmaintained/x/widgets/wm/frame/drag/size/size.factor
diff --git a/extra/x/widgets/wm/frame/frame.factor b/unmaintained/x/widgets/wm/frame/frame.factor
similarity index 100%
rename from extra/x/widgets/wm/frame/frame.factor
rename to unmaintained/x/widgets/wm/frame/frame.factor
diff --git a/extra/x/widgets/wm/menu/authors.txt b/unmaintained/x/widgets/wm/menu/authors.txt
similarity index 100%
rename from extra/x/widgets/wm/menu/authors.txt
rename to unmaintained/x/widgets/wm/menu/authors.txt
diff --git a/extra/x/widgets/wm/menu/menu.factor b/unmaintained/x/widgets/wm/menu/menu.factor
similarity index 100%
rename from extra/x/widgets/wm/menu/menu.factor
rename to unmaintained/x/widgets/wm/menu/menu.factor
diff --git a/extra/x/widgets/wm/root/authors.txt b/unmaintained/x/widgets/wm/root/authors.txt
similarity index 100%
rename from extra/x/widgets/wm/root/authors.txt
rename to unmaintained/x/widgets/wm/root/authors.txt
diff --git a/extra/x/widgets/wm/root/root.factor b/unmaintained/x/widgets/wm/root/root.factor
similarity index 100%
rename from extra/x/widgets/wm/root/root.factor
rename to unmaintained/x/widgets/wm/root/root.factor
diff --git a/extra/x/widgets/wm/unmapped-frames-menu/authors.txt b/unmaintained/x/widgets/wm/unmapped-frames-menu/authors.txt
similarity index 100%
rename from extra/x/widgets/wm/unmapped-frames-menu/authors.txt
rename to unmaintained/x/widgets/wm/unmapped-frames-menu/authors.txt
diff --git a/extra/x/widgets/wm/unmapped-frames-menu/unmapped-frames-menu.factor b/unmaintained/x/widgets/wm/unmapped-frames-menu/unmapped-frames-menu.factor
similarity index 100%
rename from extra/x/widgets/wm/unmapped-frames-menu/unmapped-frames-menu.factor
rename to unmaintained/x/widgets/wm/unmapped-frames-menu/unmapped-frames-menu.factor
diff --git a/extra/x/widgets/wm/workspace/authors.txt b/unmaintained/x/widgets/wm/workspace/authors.txt
similarity index 100%
rename from extra/x/widgets/wm/workspace/authors.txt
rename to unmaintained/x/widgets/wm/workspace/authors.txt
diff --git a/extra/x/widgets/wm/workspace/workspace.factor b/unmaintained/x/widgets/wm/workspace/workspace.factor
similarity index 100%
rename from extra/x/widgets/wm/workspace/workspace.factor
rename to unmaintained/x/widgets/wm/workspace/workspace.factor
diff --git a/extra/x/x.factor b/unmaintained/x/x.factor
similarity index 100%
rename from extra/x/x.factor
rename to unmaintained/x/x.factor
From 84ce5c3b9114a87c08b57d2ad8785456446db1ba Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 19:15:09 -0600
Subject: [PATCH 144/157] Windows workaround
---
basis/editors/emacs/emacs.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/editors/emacs/emacs.factor b/basis/editors/emacs/emacs.factor
index 1550fccc0b..79387f9820 100644
--- a/basis/editors/emacs/emacs.factor
+++ b/basis/editors/emacs/emacs.factor
@@ -1,11 +1,11 @@
USING: definitions io.launcher kernel parser words sequences math
-math.parser namespaces editors make ;
+math.parser namespaces editors make system ;
IN: editors.emacs
: emacsclient ( file line -- )
[
\ emacsclient get "emacsclient" or ,
- "--no-wait" ,
+ os windows? [ "--no-wait" , ] unless
"+" swap number>string append ,
,
] { } make try-process ;
From e4dde55d725ecfcffa6f18963625c7cb383b6a14 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 19:15:51 -0600
Subject: [PATCH 145/157] On Windows, we now look for factor-rc and
factor-boot-rc, instead of .factor-rc and .factor-boot-rc, since Explorer
doesn't like filenames with leading periods
---
basis/command-line/command-line-docs.factor | 48 ++++++++++++++++-----
basis/command-line/command-line.factor | 8 +++-
2 files changed, 43 insertions(+), 13 deletions(-)
diff --git a/basis/command-line/command-line-docs.factor b/basis/command-line/command-line-docs.factor
index d1b18ab5da..65d290df3a 100644
--- a/basis/command-line/command-line-docs.factor
+++ b/basis/command-line/command-line-docs.factor
@@ -2,10 +2,10 @@ USING: help.markup help.syntax parser vocabs.loader strings ;
IN: command-line
HELP: run-bootstrap-init
-{ $description "Runs the " { $snippet ".factor-boot-rc" } " file in the user's home directory unless the " { $snippet "-no-user-init" } " command line switch was given." } ;
+{ $description "Runs the bootstrap initialization file in the user's home directory, unless the " { $snippet "-no-user-init" } " command line switch was given. This file is named " { $snippet ".factor-boot-rc" } " on Unix and " { $snippet "factor-boot-rc" } " on Windows." } ;
HELP: run-user-init
-{ $description "Runs the " { $snippet ".factor-rc" } " file in the user's home directory unless the " { $snippet "-no-user-init" } " command line switch was given." } ;
+{ $description "Runs the startup initialization file in the user's home directory, unless the " { $snippet "-no-user-init" } " command line switch was given. This file is named " { $snippet ".factor-rc" } " on Unix and " { $snippet "factor-rc" } " on Windows." } ;
HELP: cli-param
{ $values { "param" string } }
@@ -57,7 +57,7 @@ ARTICLE: "bootstrap-cli-args" "Command line switches for bootstrap"
"A number of command line switches can be passed to a bootstrap image to modify the behavior of the resulting image:"
{ $table
{ { $snippet "-output-image=" { $emphasis "image" } } { "Save the result to " { $snippet "image" } ". The default is " { $snippet "factor.image" } "." } }
- { { $snippet "-no-user-init" } { "Inhibits the running of the " { $snippet ".factor-boot-rc" } " file in the user's home directory." } }
+ { { $snippet "-no-user-init" } { "Inhibits the running of user initialization files on startup. See " { $link "rc-files" } "." } }
{ { $snippet "-include=" { $emphasis "components..." } } "A list of components to include (see below)." }
{ { $snippet "-exclude=" { $emphasis "components..." } } "A list of components to exclude." }
{ { $snippet "-ui-backend=" { $emphasis "backend" } } { "One of " { $snippet "x11" } ", " { $snippet "windows" } ", or " { $snippet "cocoa" } ". The default is platform-specific." } }
@@ -74,9 +74,9 @@ ARTICLE: "bootstrap-cli-args" "Command line switches for bootstrap"
"By default, all optional components are loaded. To load all optional components except for a given list, use the " { $snippet "-exclude=" } " switch; to only load specified optional components, use the " { $snippet "-include=" } "."
$nl
"For example, to build an image with the compiler but no other components, you could do:"
-{ $code "./factor -i=boot.ppc.image -include=compiler" }
+{ $code "./factor -i=boot.macosx-ppc.image -include=compiler" }
"To build an image with everything except for the user interface and graphical tools,"
-{ $code "./factor -i=boot.ppc.image -exclude=\"ui ui.tools\"" }
+{ $code "./factor -i=boot.macosx-ppc.image -exclude=\"ui ui.tools\"" }
"To generate a bootstrap image in the first place, see " { $link "bootstrap.image" } "." ;
ARTICLE: "standard-cli-args" "Command line switches for general usage"
@@ -84,17 +84,43 @@ ARTICLE: "standard-cli-args" "Command line switches for general usage"
{ $table
{ { $snippet "-e=" { $emphasis "code" } } { "This specifies a code snippet to evaluate. If you want Factor to exit immediately after, also specify " { $snippet "-run=none" } "." } }
{ { $snippet "-run=" { $emphasis "vocab" } } { { $snippet { $emphasis "vocab" } } " is the name of a vocabulary with a " { $link POSTPONE: MAIN: } " hook to run on startup, for example " { $vocab-link "listener" } ", " { $vocab-link "ui" } " or " { $vocab-link "none" } "." } }
- { { $snippet "-no-user-init" } { "Inhibits the running of the " { $snippet ".factor-rc" } " file in the user's home directory on startup." } }
+ { { $snippet "-no-user-init" } { "Inhibits the running of user initialization files on startup. See " { $link "rc-files" } "." } }
{ { $snippet "-quiet" } { "If set, " { $link run-file } " and " { $link require } " will not print load messages." } }
{ { $snippet "-script" } { "Equivalent to " { $snippet "-quiet -run=none" } "." $nl "On Unix systems, Factor can be used for scripting - just create an executable text file whose first line is:" { $code "#! /usr/local/bin/factor -script" } "The space after " { $snippet "#!" } " is necessary because of Factor syntax." } }
} ;
-ARTICLE: "rc-files" "Running code on startup"
-"Unless the " { $snippet "-no-user-init" } " command line switch is specified, The startup routine runs the " { $snippet ".factor-rc" } " file in the user's home directory, if it exists. This file can contain initialization and customization for your development environment."
+ARTICLE: "factor-boot-rc" "Bootstrap initialization file"
+"The botstrap initialization file is named " { $snippet "factor-boot-rc" } " on Windows and " { $snippet ".factor-boot-rc" } " on Unix. This file can contain " { $link require } " calls for vocabularies you use frequently, and other such long-running tasks that you do not want to perform every time Factor starts."
$nl
-"The " { $snippet ".factor-rc" } " and " { $snippet ".factor-boot-rc" } " files can be run explicitly:"
-{ $subsection run-user-init }
-{ $subsection run-bootstrap-init } ;
+"A word to run this file from an existing Factor session:"
+{ $subsection run-bootstrap-init }
+"For example, if you changed " { $snippet ".factor-boot-rc" } " and do not want to bootstrap again, you can just invoke " { $link run-bootstrap-init } " in the listener." ;
+
+ARTICLE: "factor-rc" "Startup initialization file"
+"The startup initialization file is named " { $snippet "factor-rc" } " on Windows and " { $snippet ".factor-rc" } " on Unix. If it exists, it is run every time Factor starts."
+$nl
+"A word to run this file from an existing Factor session:"
+{ $subsection run-user-init } ;
+
+ARTICLE: "rc-files" "Running code on startup"
+"Factor looks for two files in your home directory."
+{ $subsection "factor-boot-rc" }
+{ $subsection "factor-rc" }
+"The " { $snippet "-no-user-init" } " command line switch will inhibit the running of these files."
+$nl
+"If you are unsure where the files should be located, evaluate the following code:"
+{ $code
+ "USE: command-line"
+ "\"factor-rc\" rc-path print"
+ "\"factor-boot-rc\" rc-path print"
+}
+"Here is an example " { $snippet ".factor-boot-rc" } " which sets up GVIM editor integration, adds an additional vocabulary root (see " { $link "vocabs.roots" } "), and increases the font size in the UI by setting the DPI (dots-per-inch) variable:"
+{ $code
+ "USING: editors.gvim vocabs.loader ui.freetype namespaces sequences ;"
+ "\"/opt/local/bin\" \\ gvim-path set-global"
+ "\"/home/jane/src/\" vocab-roots get push"
+ "100 dpi set-global"
+} ;
ARTICLE: "cli" "Command line usage"
"Zero or more command line arguments may be passed to the Factor runtime. Command line arguments starting with a dash (" { $snippet "-" } ") is interpreted as switches. All other arguments are taken to be file names to be run by " { $link run-file } "."
diff --git a/basis/command-line/command-line.factor b/basis/command-line/command-line.factor
index 37dbf9b7a6..7691f6877b 100644
--- a/basis/command-line/command-line.factor
+++ b/basis/command-line/command-line.factor
@@ -5,14 +5,18 @@ kernel.private namespaces parser sequences strings system
splitting io.files eval ;
IN: command-line
+: rc-path ( name -- path )
+ os windows? [ "." prepend ] unless
+ home prepend-path ;
+
: run-bootstrap-init ( -- )
"user-init" get [
- home ".factor-boot-rc" append-path ?run-file
+ "factor-boot-rc" rc-path ?run-file
] when ;
: run-user-init ( -- )
"user-init" get [
- home ".factor-rc" append-path ?run-file
+ "factor-rc" rc-path ?run-file
] when ;
: cli-var-param ( name value -- ) swap set-global ;
From 251f9213c328d2a8fff678244ad9f49d21a700eb Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 19:19:53 -0600
Subject: [PATCH 146/157] Fix typo
---
core/vocabs/loader/loader-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor
index ebaf8b3c8f..1325110122 100644
--- a/core/vocabs/loader/loader-docs.factor
+++ b/core/vocabs/loader/loader-docs.factor
@@ -11,7 +11,7 @@ ARTICLE: "vocabs.roots" "Vocabulary roots"
{ { $snippet "extra" } " - additional contributed libraries." }
{ { $snippet "work" } " - a root for vocabularies which are not intended to be contributed back to Factor." }
}
-"Your own vocabularies should go into " { $snippet "extra" } " or " { $snippet "work" } ", depending on whether or not you intend to contribute them back to the Factor project. If you wish to work on vocabularies outside of the Factor source directory, create a " { $snippet "~/.factor-rc" } " file like the following,"
+"Your own vocabularies should go into " { $snippet "extra" } " or " { $snippet "work" } ", depending on whether or not you intend to contribute them back to the Factor project. If you wish to work on vocabularies outside of the Factor source directory, create a " { $link "factor-boot-rc" } " file like the following:"
{ $code
"USING: namespaces sequences vocabs.loader ;"
"\"/home/jane/sources/\" vocab-roots get push"
From 8b5b887b7e19fab8df254484c6a46376da3bc9be Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 19:20:35 -0600
Subject: [PATCH 147/157] geom depends on mortar which has compiler errors.
moving to unmaintained
---
extra/cfdg/models/game1-turn6/game1-turn6.factor | 2 +-
extra/cfdg/models/sierpinski/sierpinski.factor | 2 +-
{extra => unmaintained}/geom/dim/authors.txt | 0
{extra => unmaintained}/geom/dim/dim.factor | 0
{extra => unmaintained}/geom/pos/authors.txt | 0
{extra => unmaintained}/geom/pos/pos.factor | 0
{extra => unmaintained}/geom/rect/authors.txt | 0
{extra => unmaintained}/geom/rect/rect.factor | 0
8 files changed, 2 insertions(+), 2 deletions(-)
rename {extra => unmaintained}/geom/dim/authors.txt (100%)
rename {extra => unmaintained}/geom/dim/dim.factor (100%)
rename {extra => unmaintained}/geom/pos/authors.txt (100%)
rename {extra => unmaintained}/geom/pos/pos.factor (100%)
rename {extra => unmaintained}/geom/rect/authors.txt (100%)
rename {extra => unmaintained}/geom/rect/rect.factor (100%)
diff --git a/extra/cfdg/models/game1-turn6/game1-turn6.factor b/extra/cfdg/models/game1-turn6/game1-turn6.factor
index 5e512cd74a..66424acff7 100644
--- a/extra/cfdg/models/game1-turn6/game1-turn6.factor
+++ b/extra/cfdg/models/game1-turn6/game1-turn6.factor
@@ -1,6 +1,6 @@
USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate
- mortar random-weighted cfdg ;
+ random-weighted cfdg ;
IN: cfdg.models.game1-turn6
diff --git a/extra/cfdg/models/sierpinski/sierpinski.factor b/extra/cfdg/models/sierpinski/sierpinski.factor
index 2333506f29..8257302a3e 100644
--- a/extra/cfdg/models/sierpinski/sierpinski.factor
+++ b/extra/cfdg/models/sierpinski/sierpinski.factor
@@ -1,6 +1,6 @@
USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate
- mortar random-weighted cfdg ;
+ random-weighted cfdg ;
IN: cfdg.models.sierpinski
diff --git a/extra/geom/dim/authors.txt b/unmaintained/geom/dim/authors.txt
similarity index 100%
rename from extra/geom/dim/authors.txt
rename to unmaintained/geom/dim/authors.txt
diff --git a/extra/geom/dim/dim.factor b/unmaintained/geom/dim/dim.factor
similarity index 100%
rename from extra/geom/dim/dim.factor
rename to unmaintained/geom/dim/dim.factor
diff --git a/extra/geom/pos/authors.txt b/unmaintained/geom/pos/authors.txt
similarity index 100%
rename from extra/geom/pos/authors.txt
rename to unmaintained/geom/pos/authors.txt
diff --git a/extra/geom/pos/pos.factor b/unmaintained/geom/pos/pos.factor
similarity index 100%
rename from extra/geom/pos/pos.factor
rename to unmaintained/geom/pos/pos.factor
diff --git a/extra/geom/rect/authors.txt b/unmaintained/geom/rect/authors.txt
similarity index 100%
rename from extra/geom/rect/authors.txt
rename to unmaintained/geom/rect/authors.txt
diff --git a/extra/geom/rect/rect.factor b/unmaintained/geom/rect/rect.factor
similarity index 100%
rename from extra/geom/rect/rect.factor
rename to unmaintained/geom/rect/rect.factor
From 9e82f1f8dd96efccbd3834f01d34ebf93258cc19 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 19:42:53 -0600
Subject: [PATCH 148/157] Better inference error messages
---
basis/compiler/tree/builder/builder.factor | 12 ++++--------
basis/stack-checker/errors/errors.factor | 2 +-
.../recursive-state/recursive-state.factor | 4 +---
3 files changed, 6 insertions(+), 12 deletions(-)
diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor
index c2ec6552cd..4e79c4cd2d 100644
--- a/basis/compiler/tree/builder/builder.factor
+++ b/basis/compiler/tree/builder/builder.factor
@@ -34,14 +34,10 @@ IN: compiler.tree.builder
if ;
: (build-tree-from-word) ( word -- )
- dup
- [ "inline" word-prop ]
- [ "recursive" word-prop ] bi and [
- 1quotation f initial-recursive-state infer-quot
- ] [
- [ specialized-def ] [ initial-recursive-state ] bi
- infer-quot
- ] if ;
+ dup initial-recursive-state recursive-state set
+ dup [ "inline" word-prop ] [ "recursive" word-prop ] bi and
+ [ 1quotation ] [ specialized-def ] if
+ infer-quot-here ;
: check-cannot-infer ( word -- )
dup "cannot-infer" word-prop [ cannot-infer-effect ] [ drop ] if ;
diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor
index efdc7e23b2..9fb2b59f6c 100644
--- a/basis/stack-checker/errors/errors.factor
+++ b/basis/stack-checker/errors/errors.factor
@@ -24,7 +24,7 @@ M: inference-error error-help error>> error-help ;
+warning+ (inference-error) ; inline
M: inference-error error.
- [ "In word: " write word>> . ] [ error>> error. ] bi ;
+ [ word>> [ "In word: " write . ] when* ] [ error>> error. ] bi ;
TUPLE: literal-expected ;
diff --git a/basis/stack-checker/recursive-state/recursive-state.factor b/basis/stack-checker/recursive-state/recursive-state.factor
index 41d7331230..9abfb1fcd5 100644
--- a/basis/stack-checker/recursive-state/recursive-state.factor
+++ b/basis/stack-checker/recursive-state/recursive-state.factor
@@ -4,9 +4,7 @@ USING: accessors arrays sequences kernel sequences assocs
namespaces stack-checker.recursive-state.tree ;
IN: stack-checker.recursive-state
-TUPLE: recursive-state words word quotations inline-words ;
-
-C: <recursive-state> recursive-state
+TUPLE: recursive-state word words quotations inline-words ;
: prepare-recursive-state ( word rstate -- rstate )
swap >>word
From f29300c6ba727579ce289766a25a240fc8288681 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 16 Nov 2008 19:47:52 -0600
Subject: [PATCH 149/157] Better error message when vocab top level forms leave
crap on the stack
---
core/vocabs/loader/loader-tests.factor | 9 +++++++--
core/vocabs/loader/loader.factor | 2 +-
core/vocabs/loader/test/e/e.factor | 1 +
core/vocabs/loader/test/e/tags.txt | 1 +
4 files changed, 10 insertions(+), 3 deletions(-)
create mode 100644 core/vocabs/loader/test/e/e.factor
create mode 100644 core/vocabs/loader/test/e/tags.txt
diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor
index 5ba7f7ed88..3f06b9735c 100644
--- a/core/vocabs/loader/loader-tests.factor
+++ b/core/vocabs/loader/loader-tests.factor
@@ -1,9 +1,9 @@
-! Unit tests for vocabs.loader vocabulary
IN: vocabs.loader.tests
USING: vocabs.loader tools.test continuations vocabs math
kernel arrays sequences namespaces io.streams.string
parser source-files words assocs classes.tuple definitions
-debugger compiler.units tools.vocabs accessors eval ;
+debugger compiler.units tools.vocabs accessors eval
+combinators ;
! This vocab should not exist, but just in case...
[ ] [
@@ -151,3 +151,8 @@ forget-junk
[ "xabbabbja" forget-vocab ] with-compilation-unit
forget-junk
+
+[ ] [ [ "vocabs.loader.test.e" forget-vocab ] with-compilation-unit ] unit-test
+
+[ "vocabs.loader.test.e" require ]
+[ relative-overflow? ] must-fail-with
diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor
index f48a3d1950..690b8b0d92 100644
--- a/core/vocabs/loader/loader.factor
+++ b/core/vocabs/loader/loader.factor
@@ -55,7 +55,7 @@ SYMBOL: load-help?
f over set-vocab-source-loaded?
[ vocab-source-path [ parse-file ] [ [ ] ] if* ] keep
t swap set-vocab-source-loaded?
- [ % ] [ call ] if-bootstrapping ;
+ [ % ] [ assert-depth ] if-bootstrapping ;
: load-docs ( vocab -- vocab )
load-help? get [
diff --git a/core/vocabs/loader/test/e/e.factor b/core/vocabs/loader/test/e/e.factor
new file mode 100644
index 0000000000..b85905ec0b
--- /dev/null
+++ b/core/vocabs/loader/test/e/e.factor
@@ -0,0 +1 @@
+1 2 3
diff --git a/core/vocabs/loader/test/e/tags.txt b/core/vocabs/loader/test/e/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/core/vocabs/loader/test/e/tags.txt
@@ -0,0 +1 @@
+unportable
From 67878c389ba48283ec32341b1cad76056fbbc801 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 16 Nov 2008 20:55:25 -0600
Subject: [PATCH 150/157] automata: minor indentation fix
---
extra/automata/automata.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/automata/automata.factor b/extra/automata/automata.factor
index 979a733692..0f3fdcd3f6 100644
--- a/extra/automata/automata.factor
+++ b/extra/automata/automata.factor
@@ -25,7 +25,7 @@ VAR: rule VAR: rule-number
: rule-values ( n -- seq ) >bin 8 CHAR: 0 pad-left string>digits ;
: set-rule ( n -- )
-dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ;
+ dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! step-capped-line
@@ -37,7 +37,7 @@ dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ;
: cap-line ( line -- 0-line-0 ) { 0 } prepend { 0 } append ;
: wrap-line ( a-line-z -- za-line-za )
-dup peek 1array swap dup first 1array append append ;
+ dup peek 1array swap dup first 1array append append ;
: step-line ( line -- new-line ) 3 <clumps> [ pattern>state ] map ;
From 7688c8eb482f2ae80c66a0d677b29932bc83fd2a Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 16 Nov 2008 21:20:00 -0600
Subject: [PATCH 151/157] automata: more indentation fixes
---
extra/automata/automata.factor | 22 +++++++++++-----------
1 file changed, 11 insertions(+), 11 deletions(-)
diff --git a/extra/automata/automata.factor b/extra/automata/automata.factor
index 0f3fdcd3f6..9001521490 100644
--- a/extra/automata/automata.factor
+++ b/extra/automata/automata.factor
@@ -13,14 +13,14 @@ VAR: rule VAR: rule-number
: init-rule ( -- ) 8 <hashtable> >rule ;
: rule-keys ( -- array )
-{ { 1 1 1 }
- { 1 1 0 }
- { 1 0 1 }
- { 1 0 0 }
- { 0 1 1 }
- { 0 1 0 }
- { 0 0 1 }
- { 0 0 0 } } ;
+ { { 1 1 1 }
+ { 1 1 0 }
+ { 1 0 1 }
+ { 1 0 0 }
+ { 0 1 1 }
+ { 0 1 0 }
+ { 0 0 1 }
+ { 0 0 0 } } ;
: rule-values ( n -- seq ) >bin 8 CHAR: 0 pad-left string>digits ;
@@ -61,8 +61,8 @@ VARS: width height ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: interesting ( -- seq )
-{ 18 22 26 30 41 45 54 60 73 75 82 86 89 90 97 101 102 105 106 107 109
- 110 120 121 122 124 126 129 137 146 147 149 150 151 153 154 161 165 } ;
+ { 18 22 26 30 41 45 54 60 73 75 82 86 89 90 97 101 102 105 106 107 109
+ 110 120 121 122 124 126 129 137 146 147 149 150 151 153 154 161 165 } ;
: mild ( -- seq ) { 6 9 11 57 62 74 118 } ;
@@ -75,7 +75,7 @@ VAR: bitmap
VAR: last-line
: run-rule ( -- )
-last-line> height> [ drop step-capped-line dup ] map >bitmap >last-line ;
+ last-line> height> [ drop step-capped-line dup ] map >bitmap >last-line ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
From fb45cd9e5549888702aa91f130439d67f12c7d43 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 16 Nov 2008 23:31:36 -0600
Subject: [PATCH 152/157] automata.ui: minor indentation fix
---
extra/automata/ui/ui.factor | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/extra/automata/ui/ui.factor b/extra/automata/ui/ui.factor
index cfb0462877..9210097cab 100644
--- a/extra/automata/ui/ui.factor
+++ b/extra/automata/ui/ui.factor
@@ -39,10 +39,10 @@ VAR: slate
! Call a 'model' quotation with the current 'view'.
: with-view ( quot -- )
-slate> rect-dim first >width
-slate> rect-dim second >height
-call
-slate> relayout-1 ;
+ slate> rect-dim first >width
+ slate> rect-dim second >height
+ call
+ slate> relayout-1 ;
! Create a quotation that is appropriate for buttons and gesture handler.
From 403381a6f3b48cd89274ef457df3f6773884025c Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 17 Nov 2008 00:49:42 -0600
Subject: [PATCH 153/157] boids: minor indentation fix
---
extra/boids/boids.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor
index 8c045ee270..c3cf1077e9 100644
--- a/extra/boids/boids.factor
+++ b/extra/boids/boids.factor
@@ -76,7 +76,7 @@ VAR: separation-radius
: constrain ( n a b -- n ) rot min max ;
: angle-between ( vec vec -- angle )
-2dup v. -rot norm swap norm * / -1 1 constrain acos rad>deg ;
+ 2dup v. -rot norm swap norm * / -1 1 constrain acos rad>deg ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
From 3f85a4e7273292cbe6c6bd82a0a609f387408635 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@finkelstein.stack-effects.info>
Date: Mon, 17 Nov 2008 05:16:34 -0600
Subject: [PATCH 154/157] OpenGL rendering tweaks
---
basis/opengl/opengl.factor | 10 +++++-----
basis/ui/freetype/freetype.factor | 1 -
basis/ui/gadgets/editors/editors.factor | 4 ++--
basis/ui/render/render.factor | 2 +-
4 files changed, 8 insertions(+), 9 deletions(-)
diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor
index 64326f340e..8e9cd3a3b8 100644
--- a/basis/opengl/opengl.factor
+++ b/basis/opengl/opengl.factor
@@ -31,7 +31,7 @@ IN: opengl
over glEnableClientState dip glDisableClientState ; inline
: words>values ( word/value-seq -- value-seq )
- [ dup word? [ execute ] [ ] if ] map ;
+ [ dup word? [ execute ] when ] map ;
: (all-enabled) ( seq quot -- )
over [ glEnable ] each dip [ glDisable ] each ; inline
@@ -71,10 +71,10 @@ MACRO: all-enabled-client-state ( seq quot -- )
: (rect-vertices) ( dim -- vertices )
{
- [ drop 0 1 ]
- [ first 1- 1 ]
- [ [ first 1- ] [ second ] bi ]
- [ second 0 swap ]
+ [ drop 0.5 0.5 ]
+ [ first 0.5 ]
+ [ [ first ] [ second ] bi ]
+ [ second 0.5 swap ]
} cleave 8 narray >c-float-array ;
: rect-vertices ( dim -- )
diff --git a/basis/ui/freetype/freetype.factor b/basis/ui/freetype/freetype.factor
index 5a6118fb00..d2dfe56ed4 100644
--- a/basis/ui/freetype/freetype.factor
+++ b/basis/ui/freetype/freetype.factor
@@ -196,7 +196,6 @@ M: freetype-renderer string-height ( open-font string -- h )
:: (draw-string) ( open-font sprites string loc -- )
GL_TEXTURE_2D [
loc [
- -0.5 0.5 0.0 glTranslated
string open-font string char-widths scan-sums [
[ open-font sprites ] 2dip draw-char
] 2each
diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor
index 0d0611f532..74647a6afb 100644
--- a/basis/ui/gadgets/editors/editors.factor
+++ b/basis/ui/gadgets/editors/editors.factor
@@ -112,7 +112,7 @@ M: editor ungraft*
line-height * ;
: caret-loc ( editor -- loc )
- [ editor-caret* ] keep 2dup loc>x
+ [ editor-caret* ] keep 2dup loc>x 1+
rot first rot line>y 2array ;
: caret-dim ( editor -- dim )
@@ -120,7 +120,7 @@ M: editor ungraft*
: scroll>caret ( editor -- )
dup graft-state>> second [
- dup caret-loc over caret-dim { 1 0 } v+ <rect>
+ dup caret-loc over caret-dim <rect>
over scroll>rect
] when drop ;
diff --git a/basis/ui/render/render.factor b/basis/ui/render/render.factor
index 71304aca0b..1e4c9c34f1 100644
--- a/basis/ui/render/render.factor
+++ b/basis/ui/render/render.factor
@@ -23,7 +23,7 @@ SYMBOL: viewport-translation
[ rect-intersect ] keep
dim>> dup { 0 1 } v* viewport-translation set
{ 0 0 } over gl-viewport
- -0.5 swap first2 [ 0.5 - ] [ 0.5 + ] bi* 0.5 gluOrtho2D
+ 0 swap first2 0 gluOrtho2D
clip set
do-clip ;
From b4ae47dfc89374bddbac809268c41d45aaa71fda Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 17 Nov 2008 05:56:53 -0600
Subject: [PATCH 155/157] More OpenGL tweaks
---
basis/opengl/opengl.factor | 6 +++---
basis/ui/gadgets/grid-lines/grid-lines.factor | 7 +++++--
2 files changed, 8 insertions(+), 5 deletions(-)
diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor
index 8e9cd3a3b8..aec7960857 100644
--- a/basis/opengl/opengl.factor
+++ b/basis/opengl/opengl.factor
@@ -72,9 +72,9 @@ MACRO: all-enabled-client-state ( seq quot -- )
: (rect-vertices) ( dim -- vertices )
{
[ drop 0.5 0.5 ]
- [ first 0.5 ]
- [ [ first ] [ second ] bi ]
- [ second 0.5 swap ]
+ [ first 0.5 - 0.5 ]
+ [ [ first 0.5 - ] [ second 0.5 - ] bi ]
+ [ second 0.5 - 0.5 swap ]
} cleave 8 narray >c-float-array ;
: rect-vertices ( dim -- )
diff --git a/basis/ui/gadgets/grid-lines/grid-lines.factor b/basis/ui/gadgets/grid-lines/grid-lines.factor
index 0356e7fd4d..d7844e3fa3 100644
--- a/basis/ui/gadgets/grid-lines/grid-lines.factor
+++ b/basis/ui/gadgets/grid-lines/grid-lines.factor
@@ -27,6 +27,9 @@ M: grid-lines draw-boundary
dup grid set
dup rect-dim half-gap v- grid-dim set
compute-grid
- { 0 1 } draw-grid-lines
- { 1 0 } draw-grid-lines
+ [ { 1 0 } draw-grid-lines ]
+ [
+ { 0.5 -0.5 } gl-translate
+ { 0 1 } draw-grid-lines
+ ] bi*
] with-scope ;
From 55ce87466f012224a06998fcc20563c4adc10959 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 17 Nov 2008 06:20:25 -0600
Subject: [PATCH 156/157] boids: more indentation fixes
---
extra/boids/boids.factor | 20 ++++++++++----------
1 file changed, 10 insertions(+), 10 deletions(-)
diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor
index c3cf1077e9..193582524c 100644
--- a/extra/boids/boids.factor
+++ b/extra/boids/boids.factor
@@ -43,19 +43,19 @@ VAR: separation-radius
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: init-variables ( -- )
-1.0 >cohesion-weight
-1.0 >alignment-weight
-1.0 >separation-weight
+ 1.0 >cohesion-weight
+ 1.0 >alignment-weight
+ 1.0 >separation-weight
-75 >cohesion-radius
-50 >alignment-radius
-25 >separation-radius
+ 75 >cohesion-radius
+ 50 >alignment-radius
+ 25 >separation-radius
-180 >cohesion-view-angle
-180 >alignment-view-angle
-180 >separation-view-angle
+ 180 >cohesion-view-angle
+ 180 >alignment-view-angle
+ 180 >separation-view-angle
-10 >time-slice ;
+ 10 >time-slice ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! random-boid and random-boids
From 0eee4f89d4bdef66edce0462fd6ce31f1ea73c6b Mon Sep 17 00:00:00 2001
From: "U-SLAVA-DFB8FF805\\Slava" <Slava@slava-dfb8ff805.(none)>
Date: Mon, 17 Nov 2008 06:59:17 -0600
Subject: [PATCH 157/157] Mess around with tags
---
basis/calendar/windows/tags.txt | 1 -
basis/io/windows/tags.txt | 1 -
basis/opengl/gl/windows/tags.txt | 1 -
basis/random/windows/tags.txt | 1 -
basis/tools/deploy/windows/tags.txt | 1 -
basis/windows/com/syntax/tags.txt | 2 --
basis/windows/com/tags.txt | 2 --
basis/windows/com/wrapper/tags.txt | 2 --
basis/windows/dinput/tags.txt | 1 -
basis/windows/tags.txt | 1 -
extra/game-input/backend/dinput/tags.txt | 5 +----
extra/game-input/backend/iokit/tags.txt | 5 +----
extra/game-input/backend/tags.txt | 4 +---
extra/game-input/scancodes/tags.txt | 3 +--
extra/game-input/tags.txt | 4 +---
extra/hardware-info/windows/tags.txt | 1 -
extra/icfp/2006/tags.txt | 2 +-
extra/iokit/hid/tags.txt | 3 +--
extra/iokit/tags.txt | 3 +--
extra/joystick-demo/tags.txt | 3 +--
extra/key-caps/tags.txt | 2 +-
extra/opengl/shaders/tags.txt | 1 -
extra/peg/javascript/ast/tags.txt | 1 +
extra/peg/javascript/parser/tags.txt | 1 +
extra/peg/javascript/tags.txt | 1 +
extra/peg/javascript/tokenizer/tags.txt | 1 +
extra/spheres/tags.txt | 1 -
27 files changed, 14 insertions(+), 40 deletions(-)
mode change 100644 => 100755 basis/calendar/windows/tags.txt
mode change 100644 => 100755 basis/io/windows/tags.txt
mode change 100644 => 100755 basis/opengl/gl/windows/tags.txt
mode change 100644 => 100755 basis/random/windows/tags.txt
mode change 100644 => 100755 basis/tools/deploy/windows/tags.txt
mode change 100644 => 100755 basis/windows/com/syntax/tags.txt
mode change 100644 => 100755 basis/windows/com/tags.txt
mode change 100644 => 100755 basis/windows/com/wrapper/tags.txt
mode change 100644 => 100755 basis/windows/tags.txt
mode change 100644 => 100755 extra/game-input/backend/iokit/tags.txt
mode change 100644 => 100755 extra/game-input/backend/tags.txt
mode change 100644 => 100755 extra/game-input/scancodes/tags.txt
mode change 100644 => 100755 extra/game-input/tags.txt
mode change 100644 => 100755 extra/hardware-info/windows/tags.txt
mode change 100644 => 100755 extra/icfp/2006/tags.txt
mode change 100644 => 100755 extra/iokit/hid/tags.txt
mode change 100644 => 100755 extra/iokit/tags.txt
mode change 100644 => 100755 extra/joystick-demo/tags.txt
mode change 100644 => 100755 extra/key-caps/tags.txt
mode change 100644 => 100755 extra/opengl/shaders/tags.txt
mode change 100644 => 100755 extra/peg/javascript/ast/tags.txt
mode change 100644 => 100755 extra/peg/javascript/parser/tags.txt
mode change 100644 => 100755 extra/peg/javascript/tags.txt
mode change 100644 => 100755 extra/peg/javascript/tokenizer/tags.txt
mode change 100644 => 100755 extra/spheres/tags.txt
diff --git a/basis/calendar/windows/tags.txt b/basis/calendar/windows/tags.txt
old mode 100644
new mode 100755
index 02ec70f741..6bf68304bb
--- a/basis/calendar/windows/tags.txt
+++ b/basis/calendar/windows/tags.txt
@@ -1,2 +1 @@
unportable
-windows
diff --git a/basis/io/windows/tags.txt b/basis/io/windows/tags.txt
old mode 100644
new mode 100755
index 02ec70f741..6bf68304bb
--- a/basis/io/windows/tags.txt
+++ b/basis/io/windows/tags.txt
@@ -1,2 +1 @@
unportable
-windows
diff --git a/basis/opengl/gl/windows/tags.txt b/basis/opengl/gl/windows/tags.txt
old mode 100644
new mode 100755
index 02ec70f741..6bf68304bb
--- a/basis/opengl/gl/windows/tags.txt
+++ b/basis/opengl/gl/windows/tags.txt
@@ -1,2 +1 @@
unportable
-windows
diff --git a/basis/random/windows/tags.txt b/basis/random/windows/tags.txt
old mode 100644
new mode 100755
index 02ec70f741..6bf68304bb
--- a/basis/random/windows/tags.txt
+++ b/basis/random/windows/tags.txt
@@ -1,2 +1 @@
unportable
-windows
diff --git a/basis/tools/deploy/windows/tags.txt b/basis/tools/deploy/windows/tags.txt
old mode 100644
new mode 100755
index b58a515ed8..660d511420
--- a/basis/tools/deploy/windows/tags.txt
+++ b/basis/tools/deploy/windows/tags.txt
@@ -1,3 +1,2 @@
unportable
-windows
tools
diff --git a/basis/windows/com/syntax/tags.txt b/basis/windows/com/syntax/tags.txt
old mode 100644
new mode 100755
index 71c5900baf..2320bdd648
--- a/basis/windows/com/syntax/tags.txt
+++ b/basis/windows/com/syntax/tags.txt
@@ -1,4 +1,2 @@
unportable
-windows
-com
bindings
diff --git a/basis/windows/com/tags.txt b/basis/windows/com/tags.txt
old mode 100644
new mode 100755
index 71c5900baf..2320bdd648
--- a/basis/windows/com/tags.txt
+++ b/basis/windows/com/tags.txt
@@ -1,4 +1,2 @@
unportable
-windows
-com
bindings
diff --git a/basis/windows/com/wrapper/tags.txt b/basis/windows/com/wrapper/tags.txt
old mode 100644
new mode 100755
index 71c5900baf..2320bdd648
--- a/basis/windows/com/wrapper/tags.txt
+++ b/basis/windows/com/wrapper/tags.txt
@@ -1,4 +1,2 @@
unportable
-windows
-com
bindings
diff --git a/basis/windows/dinput/tags.txt b/basis/windows/dinput/tags.txt
index 1431506222..2320bdd648 100755
--- a/basis/windows/dinput/tags.txt
+++ b/basis/windows/dinput/tags.txt
@@ -1,3 +1,2 @@
unportable
-windows
bindings
diff --git a/basis/windows/tags.txt b/basis/windows/tags.txt
old mode 100644
new mode 100755
index 1431506222..2320bdd648
--- a/basis/windows/tags.txt
+++ b/basis/windows/tags.txt
@@ -1,3 +1,2 @@
unportable
-windows
bindings
diff --git a/extra/game-input/backend/dinput/tags.txt b/extra/game-input/backend/dinput/tags.txt
index 9098dfdba4..82506ff250 100755
--- a/extra/game-input/backend/dinput/tags.txt
+++ b/extra/game-input/backend/dinput/tags.txt
@@ -1,5 +1,2 @@
unportable
-input
-gamepads
-joysticks
-windows
+games
diff --git a/extra/game-input/backend/iokit/tags.txt b/extra/game-input/backend/iokit/tags.txt
old mode 100644
new mode 100755
index 704b10bc4c..82506ff250
--- a/extra/game-input/backend/iokit/tags.txt
+++ b/extra/game-input/backend/iokit/tags.txt
@@ -1,5 +1,2 @@
unportable
-gamepads
-joysticks
-mac
-input
+games
diff --git a/extra/game-input/backend/tags.txt b/extra/game-input/backend/tags.txt
old mode 100644
new mode 100755
index 48ad1f6141..84d4140a70
--- a/extra/game-input/backend/tags.txt
+++ b/extra/game-input/backend/tags.txt
@@ -1,3 +1 @@
-gamepads
-joysticks
-input
+games
diff --git a/extra/game-input/scancodes/tags.txt b/extra/game-input/scancodes/tags.txt
old mode 100644
new mode 100755
index 6f4814c59c..84d4140a70
--- a/extra/game-input/scancodes/tags.txt
+++ b/extra/game-input/scancodes/tags.txt
@@ -1,2 +1 @@
-keyboard
-input
+games
diff --git a/extra/game-input/tags.txt b/extra/game-input/tags.txt
old mode 100644
new mode 100755
index ae360e1776..84d4140a70
--- a/extra/game-input/tags.txt
+++ b/extra/game-input/tags.txt
@@ -1,3 +1 @@
-joysticks
-gamepads
-input
+games
diff --git a/extra/hardware-info/windows/tags.txt b/extra/hardware-info/windows/tags.txt
old mode 100644
new mode 100755
index 02ec70f741..6bf68304bb
--- a/extra/hardware-info/windows/tags.txt
+++ b/extra/hardware-info/windows/tags.txt
@@ -1,2 +1 @@
unportable
-windows
diff --git a/extra/icfp/2006/tags.txt b/extra/icfp/2006/tags.txt
old mode 100644
new mode 100755
index 7102ccb5bb..1e107f52e4
--- a/extra/icfp/2006/tags.txt
+++ b/extra/icfp/2006/tags.txt
@@ -1 +1 @@
-icfp
+examples
diff --git a/extra/iokit/hid/tags.txt b/extra/iokit/hid/tags.txt
old mode 100644
new mode 100755
index c83070b657..bf2a35f15b
--- a/extra/iokit/hid/tags.txt
+++ b/extra/iokit/hid/tags.txt
@@ -1,3 +1,2 @@
-mac
bindings
-system
+unportable
diff --git a/extra/iokit/tags.txt b/extra/iokit/tags.txt
old mode 100644
new mode 100755
index c83070b657..bf2a35f15b
--- a/extra/iokit/tags.txt
+++ b/extra/iokit/tags.txt
@@ -1,3 +1,2 @@
-mac
bindings
-system
+unportable
diff --git a/extra/joystick-demo/tags.txt b/extra/joystick-demo/tags.txt
old mode 100644
new mode 100755
index 4d4417f0b8..84d4140a70
--- a/extra/joystick-demo/tags.txt
+++ b/extra/joystick-demo/tags.txt
@@ -1,2 +1 @@
-gamepads
-joysticks
+games
diff --git a/extra/key-caps/tags.txt b/extra/key-caps/tags.txt
old mode 100644
new mode 100755
index c253983475..cb5fc203e1
--- a/extra/key-caps/tags.txt
+++ b/extra/key-caps/tags.txt
@@ -1 +1 @@
-keyboard
+demos
diff --git a/extra/opengl/shaders/tags.txt b/extra/opengl/shaders/tags.txt
old mode 100644
new mode 100755
index ce0345edc9..21154b6383
--- a/extra/opengl/shaders/tags.txt
+++ b/extra/opengl/shaders/tags.txt
@@ -1,3 +1,2 @@
opengl
-glsl
bindings
\ No newline at end of file
diff --git a/extra/peg/javascript/ast/tags.txt b/extra/peg/javascript/ast/tags.txt
old mode 100644
new mode 100755
index c2aac2932f..a38bf33c3c
--- a/extra/peg/javascript/ast/tags.txt
+++ b/extra/peg/javascript/ast/tags.txt
@@ -1,3 +1,4 @@
text
javascript
parsing
+languages
diff --git a/extra/peg/javascript/parser/tags.txt b/extra/peg/javascript/parser/tags.txt
old mode 100644
new mode 100755
index c2aac2932f..a38bf33c3c
--- a/extra/peg/javascript/parser/tags.txt
+++ b/extra/peg/javascript/parser/tags.txt
@@ -1,3 +1,4 @@
text
javascript
parsing
+languages
diff --git a/extra/peg/javascript/tags.txt b/extra/peg/javascript/tags.txt
old mode 100644
new mode 100755
index c2aac2932f..a38bf33c3c
--- a/extra/peg/javascript/tags.txt
+++ b/extra/peg/javascript/tags.txt
@@ -1,3 +1,4 @@
text
javascript
parsing
+languages
diff --git a/extra/peg/javascript/tokenizer/tags.txt b/extra/peg/javascript/tokenizer/tags.txt
old mode 100644
new mode 100755
index c2aac2932f..a38bf33c3c
--- a/extra/peg/javascript/tokenizer/tags.txt
+++ b/extra/peg/javascript/tokenizer/tags.txt
@@ -1,3 +1,4 @@
text
javascript
parsing
+languages
diff --git a/extra/spheres/tags.txt b/extra/spheres/tags.txt
old mode 100644
new mode 100755
index b9a82374be..36ee50526a
--- a/extra/spheres/tags.txt
+++ b/extra/spheres/tags.txt
@@ -1,3 +1,2 @@
opengl
-glsl
demos