From b77d6601415033ec95a2b01330ed7fab8126635f Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Thu, 17 Apr 2008 02:37:03 -0400
Subject: [PATCH 01/41] Initial import of Lisp-in-Factor
---
extra/lisp/authors.txt | 1 +
extra/lisp/lisp.factor | 4 ++++
extra/lisp/summary.txt | 1 +
extra/lisp/tags.txt | 1 +
4 files changed, 7 insertions(+)
create mode 100644 extra/lisp/authors.txt
create mode 100644 extra/lisp/lisp.factor
create mode 100644 extra/lisp/summary.txt
create mode 100644 extra/lisp/tags.txt
diff --git a/extra/lisp/authors.txt b/extra/lisp/authors.txt
new file mode 100644
index 0000000000..4b7af4aac0
--- /dev/null
+++ b/extra/lisp/authors.txt
@@ -0,0 +1 @@
+James Cash
diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor
new file mode 100644
index 0000000000..c604a35b1b
--- /dev/null
+++ b/extra/lisp/lisp.factor
@@ -0,0 +1,4 @@
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
+
+IN: lisp
\ No newline at end of file
diff --git a/extra/lisp/summary.txt b/extra/lisp/summary.txt
new file mode 100644
index 0000000000..8c36217f1c
--- /dev/null
+++ b/extra/lisp/summary.txt
@@ -0,0 +1 @@
+A Lisp interpreter in Factor
diff --git a/extra/lisp/tags.txt b/extra/lisp/tags.txt
new file mode 100644
index 0000000000..0ca0d1aa8c
--- /dev/null
+++ b/extra/lisp/tags.txt
@@ -0,0 +1 @@
+Lisp languages
From a033091b44b60774af70541bbd23fa22bb84e5ca Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Thu, 17 Apr 2008 12:37:31 -0400
Subject: [PATCH 02/41] Starting work on EBNF for lisp
---
extra/lisp/lisp.factor | 6 +++++-
1 file changed, 5 insertions(+), 1 deletion(-)
diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor
index c604a35b1b..e051241a32 100644
--- a/extra/lisp/lisp.factor
+++ b/extra/lisp/lisp.factor
@@ -1,4 +1,8 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
+USING: kernel peg.ebnf peg.expr ;
+IN: lisp
-IN: lisp
\ No newline at end of file
+EBNF: expr
+list = "(" ( atom | list )* ")" => [[ second 1array ]]
+;EBNF
\ No newline at end of file
From 025da7d2cd7d19bf47e28a9be0809aebc0660fd6 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Sun, 20 Apr 2008 01:41:16 -0400
Subject: [PATCH 03/41] More work on extra/lisp
---
extra/lisp/lisp.factor | 14 +++++++++++---
extra/lisp/tags.txt | 2 +-
2 files changed, 12 insertions(+), 4 deletions(-)
diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor
index e051241a32..3dba8cfb1d 100644
--- a/extra/lisp/lisp.factor
+++ b/extra/lisp/lisp.factor
@@ -1,8 +1,16 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel peg.ebnf peg.expr ;
+USING: kernel peg.ebnf peg.expr math.parser sequences arrays ;
IN: lisp
-EBNF: expr
-list = "(" ( atom | list )* ")" => [[ second 1array ]]
+EBNF: lisp-expr
+digit = [0-9] => [[ digit> ]]
+integer = (digit)+ => [[ 10 digits>integer ]]
+float = (digit)+ "." (digit)* => [[ 3 head 3append string>number ]]
+number = integer
+ | float
+identifier = [a-zA-Z] ([a-zA-Z0-9])*
+atom = number
+ | identifier
+list = "(" (atom|list)* ")" => [[ second 1array ]]
;EBNF
\ No newline at end of file
diff --git a/extra/lisp/tags.txt b/extra/lisp/tags.txt
index 0ca0d1aa8c..eee3fba9aa 100644
--- a/extra/lisp/tags.txt
+++ b/extra/lisp/tags.txt
@@ -1 +1 @@
-Lisp languages
+lisp
From 8db59121c6ece9e1eb1b12f21b0b11544e91a62d Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Mon, 21 Apr 2008 20:25:29 -0400
Subject: [PATCH 04/41] Adding some tags
---
extra/lisp/tags.txt | 1 +
1 file changed, 1 insertion(+)
diff --git a/extra/lisp/tags.txt b/extra/lisp/tags.txt
index eee3fba9aa..c369ccae57 100644
--- a/extra/lisp/tags.txt
+++ b/extra/lisp/tags.txt
@@ -1 +1,2 @@
lisp
+languages
From b1bd228cb5c73be4988f4b1f261a2e9719074b32 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Mon, 21 Apr 2008 20:25:55 -0400
Subject: [PATCH 05/41] if-conversion working
---
extra/lisp/lisp.factor | 51 +++++++++++++++++++++++++++++++++---------
1 file changed, 41 insertions(+), 10 deletions(-)
diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor
index 3dba8cfb1d..b2cb975f47 100644
--- a/extra/lisp/lisp.factor
+++ b/extra/lisp/lisp.factor
@@ -1,16 +1,47 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel peg.ebnf peg.expr math.parser sequences arrays ;
+USING: kernel peg.ebnf peg.expr math.parser sequences arrays strings combinators.lib
+namespaces combinators math ;
IN: lisp
+TUPLE: lisp-symbol name ;
+
+C: <symbol> lisp-symbol
+
EBNF: lisp-expr
-digit = [0-9] => [[ digit> ]]
-integer = (digit)+ => [[ 10 digits>integer ]]
-float = (digit)+ "." (digit)* => [[ 3 head 3append string>number ]]
-number = integer
- | float
-identifier = [a-zA-Z] ([a-zA-Z0-9])*
+_ = (" " | "\t" | "\n")*
+LPAREN = "("
+RPAREN = ")"
+digit = [0-9]
+integer = (digit)+ => [[ string>number ]]
+float = (digit)+ "." (digit)* => [[ first3 >string [ >string ] 2 ndip 3append string>number ]]
+number = float
+ | integer
+identifier = [a-zA-Z] ([^(){} ])* => [[ [ 1 head ] [ second ] bi append >string <symbol> ]]
atom = number
- | identifier
-list = "(" (atom|list)* ")" => [[ second 1array ]]
-;EBNF
\ No newline at end of file
+ | identifier
+list-item = _ (atom|list) _ => [[ second ]]
+list = LPAREN (list-item)* RPAREN => [[ second ]]
+;EBNF
+
+DEFER: convert-form
+
+: convert-body ( lisp-form -- quot )
+ [ convert-form ] map [ ] [ compose ] reduce ; inline
+
+: convert-if ( lisp-form -- quot )
+ 1 tail [ convert-form ] map reverse first3 [ % , , \ if , ] [ ] make ;
+
+: convert-general-form ( lisp-form -- quot )
+ unclip swap convert-body [ % , ] [ ] make ;
+
+: convert-list-form ( lisp-form -- quot )
+dup first
+ { { [ dup "if" <symbol> equal? ] [ convert-if ] }
+ [ drop convert-general-form ]
+ } cond ;
+
+: convert-form ( lisp-form -- quot )
+ { { [ dup [ sequence? ] [ number? not ] bi and ] [ convert-list-form ] }
+ [ [ , ] [ ] make ]
+ } cond ;
\ No newline at end of file
From 761e3bb8f5f6863078cb6671a008596520cd4c77 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Wed, 23 Apr 2008 09:01:33 -0400
Subject: [PATCH 06/41] Using bake instead of make
---
extra/lisp/lisp.factor | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor
index b2cb975f47..d2de6fe278 100644
--- a/extra/lisp/lisp.factor
+++ b/extra/lisp/lisp.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg.ebnf peg.expr math.parser sequences arrays strings combinators.lib
-namespaces combinators math ;
+namespaces combinators math bake ;
IN: lisp
TUPLE: lisp-symbol name ;
@@ -30,14 +30,14 @@ DEFER: convert-form
[ convert-form ] map [ ] [ compose ] reduce ; inline
: convert-if ( lisp-form -- quot )
- 1 tail [ convert-form ] map reverse first3 [ % , , \ if , ] [ ] make ;
+ 1 tail [ convert-form ] map reverse first3 [ % , , if ] bake ;
: convert-general-form ( lisp-form -- quot )
- unclip swap convert-body [ % , ] [ ] make ;
+ unclip swap convert-body [ % , ] bake ;
: convert-list-form ( lisp-form -- quot )
dup first
- { { [ dup "if" <symbol> equal? ] [ convert-if ] }
+ { { [ dup "if" <symbol> equal? ] [ drop convert-if ] }
[ drop convert-general-form ]
} cond ;
From 1069db6d053095278c7c9cf1b855b4784c3c788d Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Wed, 23 Apr 2008 09:01:54 -0400
Subject: [PATCH 07/41] Adding unit tests
---
extra/lisp/lisp-tests.factor | 4 ++++
1 file changed, 4 insertions(+)
create mode 100644 extra/lisp/lisp-tests.factor
diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor
new file mode 100644
index 0000000000..a3db32c915
--- /dev/null
+++ b/extra/lisp/lisp-tests.factor
@@ -0,0 +1,4 @@
+[ [ T{ lisp-symbol f "foo" } [ 2 T{ lisp-symbol f "bar" } ] [ 3 4 T{ lisp-symbol f "baz" } ] if ] ]
+ [ "(if foo (bar 2) (baz 3 4))" lisp-expr parse-result-ast convert-if ] unit-test
+
+
\ No newline at end of file
From ec79b7823f822d36930c6c1c77e1c1ff6b857324 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Thu, 24 Apr 2008 16:35:42 -0400
Subject: [PATCH 08/41] Adding lambda conversion and strings
---
extra/lisp/lisp.factor | 64 ++++++++++++++++++++++++++++++------------
1 file changed, 46 insertions(+), 18 deletions(-)
diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor
index d2de6fe278..be43d50a18 100644
--- a/extra/lisp/lisp.factor
+++ b/extra/lisp/lisp.factor
@@ -1,29 +1,38 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg.ebnf peg.expr math.parser sequences arrays strings combinators.lib
-namespaces combinators math bake ;
+namespaces combinators math bake locals.private accessors vectors syntax ;
IN: lisp
TUPLE: lisp-symbol name ;
-C: <symbol> lisp-symbol
+C: <lisp-symbol> lisp-symbol
EBNF: lisp-expr
-_ = (" " | "\t" | "\n")*
-LPAREN = "("
-RPAREN = ")"
-digit = [0-9]
-integer = (digit)+ => [[ string>number ]]
-float = (digit)+ "." (digit)* => [[ first3 >string [ >string ] 2 ndip 3append string>number ]]
-number = float
- | integer
-identifier = [a-zA-Z] ([^(){} ])* => [[ [ 1 head ] [ second ] bi append >string <symbol> ]]
-atom = number
- | identifier
-list-item = _ (atom|list) _ => [[ second ]]
-list = LPAREN (list-item)* RPAREN => [[ second ]]
+_ = (" " | "\t" | "\n")*
+LPAREN = "("
+RPAREN = ")"
+dquote = '"'
+digit = [0-9]
+integer = (digit)+ => [[ string>number ]]
+float = (digit)+ "." (digit)* => [[ first3 >string [ >string ] dipd 3append string>number ]]
+number = float
+ | integer
+id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<"
+ | " =" | ">" | "?" | "^" | "_" | "~" | "+" | "-" | "." | "@"
+letters = [a-zA-Z] => [[ 1array >string ]]
+initials = letters | id-specials
+numbers = [0-9] => [[ 1array >string ]]
+subsequents = initials | numbers
+identifier = initials (subsequents)* => [[ first2 concat append <lisp-symbol> ]]
+string = dquote ("\" . | !(dquote) . )* dquote => [[ second >string ]]
+atom = number
+ | identifier
+ | string
+list-item = _ (atom|list) _ => [[ second ]]
+list = LPAREN (list-item)* RPAREN => [[ second ]]
;EBNF
-
+
DEFER: convert-form
: convert-body ( lisp-form -- quot )
@@ -32,12 +41,31 @@ DEFER: convert-form
: convert-if ( lisp-form -- quot )
1 tail [ convert-form ] map reverse first3 [ % , , if ] bake ;
+: convert-begin ( lisp-form -- quot )
+ 1 tail convert-body ;
+
+: convert-cond ( lisp-form -- quot )
+ 1 tail [ [ convert-body map ] map ] [ % cond ] bake ;
+
: convert-general-form ( lisp-form -- quot )
unclip swap convert-body [ % , ] bake ;
-
+
+<PRIVATE
+: localize-body ( vars body -- newbody )
+ [ dup lisp-symbol? [ tuck name>> swap member? [ name>> make-local ] [ ] if ]
+ [ dup vector? [ localize-body ] [ nip ] if ] if ] with map ; inline
+PRIVATE>
+
+: convert-lambda ( lisp-form -- quot )
+ 1 tail unclip reverse [ name>> ] map dup make-locals dup push-locals
+ [ swap localize-body convert-body ] dipd pop-locals swap <lambda> ;
+
: convert-list-form ( lisp-form -- quot )
dup first
- { { [ dup "if" <symbol> equal? ] [ drop convert-if ] }
+ { { [ dup "if" <lisp-symbol> equal? ] [ drop convert-if ] }
+ { [ dup "begin" <lisp-symbol> equal? ] [ drop convert-begin ] }
+ { [ dup "cond" <lisp-symbol> equal? ] [ drop convert-cond ] }
+ { [ dup "lambda" <lisp-symbol> equal? ] [ drop convert-lambda ] }
[ drop convert-general-form ]
} cond ;
From df4023b6a76f695e91d6c50dcc7fefff1c6c9b38 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Thu, 24 Apr 2008 22:50:23 -0400
Subject: [PATCH 09/41] Fixed bug in convert-list-form
---
extra/lisp/lisp.factor | 14 +++++++-------
1 file changed, 7 insertions(+), 7 deletions(-)
diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor
index be43d50a18..624f190fb1 100644
--- a/extra/lisp/lisp.factor
+++ b/extra/lisp/lisp.factor
@@ -61,15 +61,15 @@ PRIVATE>
[ swap localize-body convert-body ] dipd pop-locals swap <lambda> ;
: convert-list-form ( lisp-form -- quot )
-dup first
- { { [ dup "if" <lisp-symbol> equal? ] [ drop convert-if ] }
- { [ dup "begin" <lisp-symbol> equal? ] [ drop convert-begin ] }
- { [ dup "cond" <lisp-symbol> equal? ] [ drop convert-cond ] }
- { [ dup "lambda" <lisp-symbol> equal? ] [ drop convert-lambda ] }
+dup first dup lisp-symbol? [ name>>
+ { { "lambda" [ convert-lambda ] }
+ { "if" [ convert-if ] }
+ { "begin" [ convert-begin ] }
+ { "cond" [ convert-cond ] }
[ drop convert-general-form ]
- } cond ;
+ } case ] [ drop convert-general-form ] if ;
: convert-form ( lisp-form -- quot )
- { { [ dup [ sequence? ] [ number? not ] bi and ] [ convert-list-form ] }
+ { { [ dup vector? ] [ convert-list-form ] }
[ [ , ] [ ] make ]
} cond ;
\ No newline at end of file
From 228430512c0ed31a055d25326bb021cc6ad7c441 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Sat, 26 Apr 2008 15:55:39 -0400
Subject: [PATCH 10/41] Splitting EBNF parser to seperate vocab
---
extra/lisp/parser/parser.factor | 36 +++++++++++++++++++++++++++++++++
1 file changed, 36 insertions(+)
create mode 100644 extra/lisp/parser/parser.factor
diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor
new file mode 100644
index 0000000000..0fac78ae75
--- /dev/null
+++ b/extra/lisp/parser/parser.factor
@@ -0,0 +1,36 @@
+USING: kernel peg.ebnf peg.expr math.parser sequences arrays strings
+combinators.lib ;
+
+IN: lisp.parser
+
+TUPLE: lisp-symbol name ;
+C: <lisp-symbol> lisp-symbol
+
+TUPLE: s-exp body ;
+C: <s-exp> s-exp
+
+EBNF: lisp-expr
+_ = (" " | "\t" | "\n")*
+LPAREN = "("
+RPAREN = ")"
+dquote = '"'
+squote = "'"
+digit = [0-9]
+integer = (digit)+ => [[ string>number ]]
+float = (digit)+ "." (digit)* => [[ first3 >string [ >string ] dipd 3append string>number ]]
+number = float
+ | integer
+id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<"
+ | " =" | ">" | "?" | "^" | "_" | "~" | "+" | "-" | "." | "@"
+letters = [a-zA-Z] => [[ 1array >string ]]
+initials = letters | id-specials
+numbers = [0-9] => [[ 1array >string ]]
+subsequents = initials | numbers
+identifier = initials (subsequents)* => [[ first2 concat append <lisp-symbol> ]]
+string = dquote ("\" . | !(dquote) . )* dquote => [[ second >string ]]
+atom = number
+ | identifier
+ | string
+list-item = _ (atom|s-expression) _ => [[ second ]]
+s-expression = LPAREN (list-item)* RPAREN => [[ second <s-exp> ]]
+;EBNF
From 1ad1f5ceba4b828c6fdf8d1e49a5a85ac2a4019d Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Sat, 26 Apr 2008 17:17:34 -0400
Subject: [PATCH 11/41] Switching back from <s-exp> tuple to vectors
---
extra/lisp/parser/parser.factor | 5 +----
1 file changed, 1 insertion(+), 4 deletions(-)
diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor
index 0fac78ae75..2375313a10 100644
--- a/extra/lisp/parser/parser.factor
+++ b/extra/lisp/parser/parser.factor
@@ -6,9 +6,6 @@ IN: lisp.parser
TUPLE: lisp-symbol name ;
C: <lisp-symbol> lisp-symbol
-TUPLE: s-exp body ;
-C: <s-exp> s-exp
-
EBNF: lisp-expr
_ = (" " | "\t" | "\n")*
LPAREN = "("
@@ -32,5 +29,5 @@ atom = number
| identifier
| string
list-item = _ (atom|s-expression) _ => [[ second ]]
-s-expression = LPAREN (list-item)* RPAREN => [[ second <s-exp> ]]
+s-expression = LPAREN (list-item)* RPAREN => [[ second ]]
;EBNF
From 0c10c13e4d315f70ca72cce99ca7d3ff8e0b6b22 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Sat, 26 Apr 2008 17:20:12 -0400
Subject: [PATCH 12/41] Bug fixes
---
extra/lisp/lisp.factor | 66 +++++++++++++-----------------------------
1 file changed, 20 insertions(+), 46 deletions(-)
diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor
index 624f190fb1..729c136a95 100644
--- a/extra/lisp/lisp.factor
+++ b/extra/lisp/lisp.factor
@@ -1,53 +1,24 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel peg.ebnf peg.expr math.parser sequences arrays strings combinators.lib
-namespaces combinators math bake locals.private accessors vectors syntax ;
+USING: kernel peg sequences arrays strings combinators.lib
+namespaces combinators math bake locals.private accessors vectors syntax lisp.parser ;
IN: lisp
-TUPLE: lisp-symbol name ;
-
-C: <lisp-symbol> lisp-symbol
-
-EBNF: lisp-expr
-_ = (" " | "\t" | "\n")*
-LPAREN = "("
-RPAREN = ")"
-dquote = '"'
-digit = [0-9]
-integer = (digit)+ => [[ string>number ]]
-float = (digit)+ "." (digit)* => [[ first3 >string [ >string ] dipd 3append string>number ]]
-number = float
- | integer
-id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<"
- | " =" | ">" | "?" | "^" | "_" | "~" | "+" | "-" | "." | "@"
-letters = [a-zA-Z] => [[ 1array >string ]]
-initials = letters | id-specials
-numbers = [0-9] => [[ 1array >string ]]
-subsequents = initials | numbers
-identifier = initials (subsequents)* => [[ first2 concat append <lisp-symbol> ]]
-string = dquote ("\" . | !(dquote) . )* dquote => [[ second >string ]]
-atom = number
- | identifier
- | string
-list-item = _ (atom|list) _ => [[ second ]]
-list = LPAREN (list-item)* RPAREN => [[ second ]]
-;EBNF
-
DEFER: convert-form
-: convert-body ( lisp-form -- quot )
+: convert-body ( s-exp -- quot )
[ convert-form ] map [ ] [ compose ] reduce ; inline
-: convert-if ( lisp-form -- quot )
+: convert-if ( s-exp -- quot )
1 tail [ convert-form ] map reverse first3 [ % , , if ] bake ;
-: convert-begin ( lisp-form -- quot )
+: convert-begin ( s-exp -- quot )
1 tail convert-body ;
-: convert-cond ( lisp-form -- quot )
+: convert-cond ( s-exp -- quot )
1 tail [ [ convert-body map ] map ] [ % cond ] bake ;
-: convert-general-form ( lisp-form -- quot )
+: convert-general-form ( s-exp -- quot )
unclip swap convert-body [ % , ] bake ;
<PRIVATE
@@ -56,20 +27,23 @@ DEFER: convert-form
[ dup vector? [ localize-body ] [ nip ] if ] if ] with map ; inline
PRIVATE>
-: convert-lambda ( lisp-form -- quot )
+: convert-lambda ( s-exp -- quot )
1 tail unclip reverse [ name>> ] map dup make-locals dup push-locals
[ swap localize-body convert-body ] dipd pop-locals swap <lambda> ;
-: convert-list-form ( lisp-form -- quot )
-dup first dup lisp-symbol? [ name>>
- { { "lambda" [ convert-lambda ] }
- { "if" [ convert-if ] }
- { "begin" [ convert-begin ] }
- { "cond" [ convert-cond ] }
- [ drop convert-general-form ]
- } case ] [ drop convert-general-form ] if ;
+: convert-list-form ( s-exp -- quot )
+ dup first dup lisp-symbol? [ name>>
+ { { "lambda" [ convert-lambda ] }
+ { "if" [ convert-if ] }
+ { "begin" [ convert-begin ] }
+ { "cond" [ convert-cond ] }
+ [ drop convert-general-form ]
+ } case ] [ drop convert-general-form ] if ;
: convert-form ( lisp-form -- quot )
{ { [ dup vector? ] [ convert-list-form ] }
[ [ , ] [ ] make ]
- } cond ;
\ No newline at end of file
+ } cond ;
+
+: lisp-string>factor ( str -- quot )
+ lisp-expr parse-result-ast convert-form ;
\ No newline at end of file
From a6f25c55fc5e480bf82efef2d25bf4364b3ee076 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Sun, 27 Apr 2008 03:03:49 -0400
Subject: [PATCH 13/41] Changing back to use a tuple for the parsed
s-expression
---
extra/lisp/lisp.factor | 10 +++++-----
extra/lisp/parser/parser.factor | 7 +++++--
2 files changed, 10 insertions(+), 7 deletions(-)
diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor
index 729c136a95..e254c51b7b 100644
--- a/extra/lisp/lisp.factor
+++ b/extra/lisp/lisp.factor
@@ -7,7 +7,7 @@ IN: lisp
DEFER: convert-form
: convert-body ( s-exp -- quot )
- [ convert-form ] map [ ] [ compose ] reduce ; inline
+ [ convert-form ] map reverse [ ] [ compose ] reduce ; inline
: convert-if ( s-exp -- quot )
1 tail [ convert-form ] map reverse first3 [ % , , if ] bake ;
@@ -18,17 +18,17 @@ DEFER: convert-form
: convert-cond ( s-exp -- quot )
1 tail [ [ convert-body map ] map ] [ % cond ] bake ;
-: convert-general-form ( s-exp -- quot )
+: convert-general-form ( s-exp -- quot )
unclip swap convert-body [ % , ] bake ;
<PRIVATE
: localize-body ( vars body -- newbody )
[ dup lisp-symbol? [ tuck name>> swap member? [ name>> make-local ] [ ] if ]
- [ dup vector? [ localize-body ] [ nip ] if ] if ] with map ; inline
+ [ dup s-exp? [ body>> localize-body <s-exp> ] [ nip ] if ] if ] with map ;
PRIVATE>
: convert-lambda ( s-exp -- quot )
- 1 tail unclip reverse [ name>> ] map dup make-locals dup push-locals
+ first3 -rot nip [ body>> ] bi@ reverse [ name>> ] map dup make-locals dup push-locals
[ swap localize-body convert-body ] dipd pop-locals swap <lambda> ;
: convert-list-form ( s-exp -- quot )
@@ -41,7 +41,7 @@ PRIVATE>
} case ] [ drop convert-general-form ] if ;
: convert-form ( lisp-form -- quot )
- { { [ dup vector? ] [ convert-list-form ] }
+ { { [ dup s-exp? ] [ body>> convert-list-form ] }
[ [ , ] [ ] make ]
} cond ;
diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor
index 2375313a10..ec079265bc 100644
--- a/extra/lisp/parser/parser.factor
+++ b/extra/lisp/parser/parser.factor
@@ -6,6 +6,9 @@ IN: lisp.parser
TUPLE: lisp-symbol name ;
C: <lisp-symbol> lisp-symbol
+TUPLE: s-exp body ;
+C: <s-exp> s-exp
+
EBNF: lisp-expr
_ = (" " | "\t" | "\n")*
LPAREN = "("
@@ -29,5 +32,5 @@ atom = number
| identifier
| string
list-item = _ (atom|s-expression) _ => [[ second ]]
-s-expression = LPAREN (list-item)* RPAREN => [[ second ]]
-;EBNF
+s-expression = LPAREN (list-item)* RPAREN => [[ second <s-exp> ]]
+;EBNF
\ No newline at end of file
From 5d689e732d7201a601df060a5e8fb3a902d4ea4e Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Sun, 27 Apr 2008 23:12:18 -0400
Subject: [PATCH 14/41] Adding requisite files to lisp.parser
---
extra/lisp/parser/authors.txt | 1 +
extra/lisp/parser/parser-tests.factor | 34 +++++++++++++++++++++++++++
extra/lisp/parser/summary.txt | 1 +
extra/lisp/parser/tags.txt | 2 ++
4 files changed, 38 insertions(+)
create mode 100644 extra/lisp/parser/authors.txt
create mode 100644 extra/lisp/parser/parser-tests.factor
create mode 100644 extra/lisp/parser/summary.txt
create mode 100644 extra/lisp/parser/tags.txt
diff --git a/extra/lisp/parser/authors.txt b/extra/lisp/parser/authors.txt
new file mode 100644
index 0000000000..4b7af4aac0
--- /dev/null
+++ b/extra/lisp/parser/authors.txt
@@ -0,0 +1 @@
+James Cash
diff --git a/extra/lisp/parser/parser-tests.factor b/extra/lisp/parser/parser-tests.factor
new file mode 100644
index 0000000000..025b45e60d
--- /dev/null
+++ b/extra/lisp/parser/parser-tests.factor
@@ -0,0 +1,34 @@
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
+USING: lisp.parser tools.test ;
+
+IN: lisp.parser.tests
+
+{ 1234 } [
+ "1234" "atom" \ lisp-expr rule parse parse-result-ast
+] unit-test
+
+{ 123.98 } [
+ "123.98" "atom" \ lisp-expr rule parse parse-result-ast
+] unit-test
+
+{ "aoeu" } [
+ "\"aoeu\"" "atom" \ lisp-expr rule parse parse-result-ast
+] unit-test
+
+{ "aoeu\"de" } [
+ "\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse parse-result-ast
+] unit-test
+
+{ T{ lisp-symbol f "foobar" } } [
+ "foobar" "atom" \ lisp-expr rule parse parse-result-ast
+] unit-test
+
+{ T{ lisp-symbol f "+" } } [
+ "+" "atom" \ lisp-expr rule parse parse-result-ast
+] unit-test
+
+{ T{ s-exp f
+ V{ T{ lisp-symbol f "foo" } 1 2 "aoeu" } } } [
+ "(foo 1 2 \"aoeu\")"
+] unit-test
\ No newline at end of file
diff --git a/extra/lisp/parser/summary.txt b/extra/lisp/parser/summary.txt
new file mode 100644
index 0000000000..aa407b3dfb
--- /dev/null
+++ b/extra/lisp/parser/summary.txt
@@ -0,0 +1 @@
+EBNF grammar for parsing Lisp
diff --git a/extra/lisp/parser/tags.txt b/extra/lisp/parser/tags.txt
new file mode 100644
index 0000000000..d1f6fa1ef3
--- /dev/null
+++ b/extra/lisp/parser/tags.txt
@@ -0,0 +1,2 @@
+lisp
+parsing
From f02ca2284cf3046dd3037a42a171e7d06ac97c7b Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Sun, 27 Apr 2008 23:12:52 -0400
Subject: [PATCH 15/41] Starting tests for lisp
---
extra/lisp/lisp-tests.factor | 9 +++++----
1 file changed, 5 insertions(+), 4 deletions(-)
diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor
index a3db32c915..6266693571 100644
--- a/extra/lisp/lisp-tests.factor
+++ b/extra/lisp/lisp-tests.factor
@@ -1,4 +1,5 @@
-[ [ T{ lisp-symbol f "foo" } [ 2 T{ lisp-symbol f "bar" } ] [ 3 4 T{ lisp-symbol f "baz" } ] if ] ]
- [ "(if foo (bar 2) (baz 3 4))" lisp-expr parse-result-ast convert-if ] unit-test
-
-
\ No newline at end of file
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
+USING: lisp tools.test ;
+
+IN: lisp.tests
\ No newline at end of file
From 062facb8097b5427481e701018fadc1824194a8b Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Sun, 27 Apr 2008 23:13:42 -0400
Subject: [PATCH 16/41] Adding copyright notice to lisp.parser
---
extra/lisp/parser/parser.factor | 2 ++
1 file changed, 2 insertions(+)
diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor
index ec079265bc..7f03846044 100644
--- a/extra/lisp/parser/parser.factor
+++ b/extra/lisp/parser/parser.factor
@@ -1,3 +1,5 @@
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg.ebnf peg.expr math.parser sequences arrays strings
combinators.lib ;
From ec95cef85ecaa3192eada818bed1724a21c46a0a Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Tue, 29 Apr 2008 23:10:47 -0400
Subject: [PATCH 17/41] Adding more tests
---
extra/lisp/lisp-tests.factor | 8 ++++++--
extra/lisp/parser/parser-tests.factor | 8 ++++++--
2 files changed, 12 insertions(+), 4 deletions(-)
diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor
index 6266693571..3e3e05b2ea 100644
--- a/extra/lisp/lisp-tests.factor
+++ b/extra/lisp/lisp-tests.factor
@@ -1,5 +1,9 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
-USING: lisp tools.test ;
+USING: lisp lisp.parser tools.test ;
-IN: lisp.tests
\ No newline at end of file
+IN: lisp.test
+
+{ [ "aoeu" 2 1 T{ lisp-symbol f "foo" } ] } [
+ "(foo 1 2 \"aoeu\")" lisp-string>factor
+] unit-test
\ No newline at end of file
diff --git a/extra/lisp/parser/parser-tests.factor b/extra/lisp/parser/parser-tests.factor
index 025b45e60d..9e6b54ab0c 100644
--- a/extra/lisp/parser/parser-tests.factor
+++ b/extra/lisp/parser/parser-tests.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
-USING: lisp.parser tools.test ;
+USING: lisp.parser tools.test peg peg.ebnf ;
IN: lisp.parser.tests
@@ -12,6 +12,10 @@ IN: lisp.parser.tests
"123.98" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test
+{ "" } [
+ "\"\"" "atom" \ lisp-expr rule parse parse-result-ast
+] unit-test
+
{ "aoeu" } [
"\"aoeu\"" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test
@@ -30,5 +34,5 @@ IN: lisp.parser.tests
{ T{ s-exp f
V{ T{ lisp-symbol f "foo" } 1 2 "aoeu" } } } [
- "(foo 1 2 \"aoeu\")"
+ "(foo 1 2 \"aoeu\")" lisp-expr parse-result-ast
] unit-test
\ No newline at end of file
From 598bb166de83b74a91477afc22e48d0f37a4baad Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Wed, 30 Apr 2008 16:59:50 -0400
Subject: [PATCH 18/41] Minor formatting changes
---
extra/lisp/lisp.factor | 39 +++++++++++++++++++++++++++++++--------
1 file changed, 31 insertions(+), 8 deletions(-)
diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor
index e254c51b7b..82eddbb2ac 100644
--- a/extra/lisp/lisp.factor
+++ b/extra/lisp/lisp.factor
@@ -5,21 +5,24 @@ namespaces combinators math bake locals.private accessors vectors syntax lisp.pa
IN: lisp
DEFER: convert-form
+DEFER: funcall
+! Functions to convert s-exps to quotations
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: convert-body ( s-exp -- quot )
[ convert-form ] map reverse [ ] [ compose ] reduce ; inline
: convert-if ( s-exp -- quot )
- 1 tail [ convert-form ] map reverse first3 [ % , , if ] bake ;
+ rest [ convert-form ] map reverse first3 [ % , , if ] bake ;
: convert-begin ( s-exp -- quot )
- 1 tail convert-body ;
+ rest convert-body ;
: convert-cond ( s-exp -- quot )
- 1 tail [ [ convert-body map ] map ] [ % cond ] bake ;
+ rest [ [ convert-body map ] map ] [ % cond ] bake ;
: convert-general-form ( s-exp -- quot )
- unclip swap convert-body [ % , ] bake ;
+ unclip swap convert-body [ % , funcall ] bake ;
<PRIVATE
: localize-body ( vars body -- newbody )
@@ -31,19 +34,39 @@ PRIVATE>
first3 -rot nip [ body>> ] bi@ reverse [ name>> ] map dup make-locals dup push-locals
[ swap localize-body convert-body ] dipd pop-locals swap <lambda> ;
+: convert-quoted ( s-exp -- quot )
+ second [ , ] bake ;
+
: convert-list-form ( s-exp -- quot )
- dup first dup lisp-symbol? [ name>>
+ dup first dup lisp-symbol?
+ [ name>>
{ { "lambda" [ convert-lambda ] }
+ { "quote" [ convert-quoted ] }
{ "if" [ convert-if ] }
{ "begin" [ convert-begin ] }
{ "cond" [ convert-cond ] }
[ drop convert-general-form ]
- } case ] [ drop convert-general-form ] if ;
+ } case ]
+ [ drop convert-general-form ] if ;
: convert-form ( lisp-form -- quot )
{ { [ dup s-exp? ] [ body>> convert-list-form ] }
[ [ , ] [ ] make ]
} cond ;
-: lisp-string>factor ( str -- quot )
- lisp-expr parse-result-ast convert-form ;
\ No newline at end of file
+: lisp-string>factor ( str -- quot )
+ lisp-expr parse-result-ast convert-form ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: lisp-env
+
+H{ } clone lisp-env set
+
+: define-lisp-word ( name body -- )
+ lisp-env get set-at ;
+
+: get-lisp-word ( name -- word )
+ lisp-env get at ;
+
+: funcall ( quot sym -- * )
+ name>> get-lisp-word call ;
\ No newline at end of file
From dcab546b97f8d7e7b2b55f9f18ae339456a59dd2 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Wed, 30 Apr 2008 17:00:20 -0400
Subject: [PATCH 19/41] Adding negative numbers to the parser, other minor
changes
---
extra/lisp/parser/parser.factor | 17 +++++++++--------
1 file changed, 9 insertions(+), 8 deletions(-)
diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor
index 7f03846044..83f0278129 100644
--- a/extra/lisp/parser/parser.factor
+++ b/extra/lisp/parser/parser.factor
@@ -18,21 +18,22 @@ RPAREN = ")"
dquote = '"'
squote = "'"
digit = [0-9]
-integer = (digit)+ => [[ string>number ]]
-float = (digit)+ "." (digit)* => [[ first3 >string [ >string ] dipd 3append string>number ]]
+integer = ("-")? (digit)+ => [[ string>number ]]
+float = ("-")? (digit)+ "." (digit)* => [[ first3 >string [ >string ] dipd 3append string>number ]]
number = float
| integer
id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<"
| " =" | ">" | "?" | "^" | "_" | "~" | "+" | "-" | "." | "@"
-letters = [a-zA-Z] => [[ 1array >string ]]
+letters = [a-zA-Z] => [[ 1array >string ]]
initials = letters | id-specials
-numbers = [0-9] => [[ 1array >string ]]
+numbers = [0-9] => [[ 1array >string ]]
subsequents = initials | numbers
-identifier = initials (subsequents)* => [[ first2 concat append <lisp-symbol> ]]
-string = dquote ("\" . | !(dquote) . )* dquote => [[ second >string ]]
+identifier = initials (subsequents)* => [[ first2 concat append <lisp-symbol> ]]
+escaped = "\" . => [[ second ]]
+string = dquote ( escaped | !(dquote) . )* dquote => [[ second >string ]]
atom = number
| identifier
| string
-list-item = _ (atom|s-expression) _ => [[ second ]]
-s-expression = LPAREN (list-item)* RPAREN => [[ second <s-exp> ]]
+list-item = _ (atom|s-expression) _ => [[ second ]]
+s-expression = LPAREN (list-item)* RPAREN => [[ second <s-exp> ]]
;EBNF
\ No newline at end of file
From 3e8e976beec14b728570a08623a3bf7097ce0efc Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Fri, 2 May 2008 03:11:10 -0400
Subject: [PATCH 20/41] Negative numbers not working now, will fix later
---
extra/lisp/parser/parser.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor
index 83f0278129..65ad01aa6f 100644
--- a/extra/lisp/parser/parser.factor
+++ b/extra/lisp/parser/parser.factor
@@ -18,8 +18,8 @@ RPAREN = ")"
dquote = '"'
squote = "'"
digit = [0-9]
-integer = ("-")? (digit)+ => [[ string>number ]]
-float = ("-")? (digit)+ "." (digit)* => [[ first3 >string [ >string ] dipd 3append string>number ]]
+integer = (digit)+ => [[ string>number ]]
+float = (digit)+ "." (digit)* => [[ first3 >string [ >string ] dipd 3append string>number ]]
number = float
| integer
id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<"
From 82cdbdeb0ecf47e6ab5081dc3d1bf75299d42b62 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Mon, 5 May 2008 12:48:58 -0400
Subject: [PATCH 21/41] Adding more unit tests for lisp
---
extra/lisp/lisp-tests.factor | 12 ++++++++++++
1 file changed, 12 insertions(+)
diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor
index 3e3e05b2ea..101af3fa5b 100644
--- a/extra/lisp/lisp-tests.factor
+++ b/extra/lisp/lisp-tests.factor
@@ -6,4 +6,16 @@ IN: lisp.test
{ [ "aoeu" 2 1 T{ lisp-symbol f "foo" } ] } [
"(foo 1 2 \"aoeu\")" lisp-string>factor
+] unit-test
+
+init-env
+
+"+" [ first2 + ] lisp-define
+
+{ [ first2 + ] } [
+ "+" lisp-get
+] unit-test
+
+{ 3 } [
+ "((lambda (x y) (+ x y)) 1 2)" lisp-string>factor call
] unit-test
\ No newline at end of file
From 42154c96096cad1125973e08dea67bf061b90144 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Mon, 5 May 2008 12:49:16 -0400
Subject: [PATCH 22/41] Trying to get var-args to work
---
extra/lisp/lisp.factor | 48 ++++++++++++++++++++++++++++--------------
1 file changed, 32 insertions(+), 16 deletions(-)
diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor
index 82eddbb2ac..7630889570 100644
--- a/extra/lisp/lisp.factor
+++ b/extra/lisp/lisp.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg sequences arrays strings combinators.lib
-namespaces combinators math bake locals.private accessors vectors syntax lisp.parser ;
+namespaces combinators math bake locals locals.private accessors
+vectors syntax lisp.parser assocs parser sequences.lib ;
IN: lisp
DEFER: convert-form
@@ -10,29 +11,42 @@ DEFER: funcall
! Functions to convert s-exps to quotations
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: convert-body ( s-exp -- quot )
- [ convert-form ] map reverse [ ] [ compose ] reduce ; inline
+ [ convert-form ] map [ ] [ compose ] reduce ; inline
: convert-if ( s-exp -- quot )
rest [ convert-form ] map reverse first3 [ % , , if ] bake ;
: convert-begin ( s-exp -- quot )
- rest convert-body ;
+ rest convert-form ;
: convert-cond ( s-exp -- quot )
- rest [ [ convert-body map ] map ] [ % cond ] bake ;
+ rest [ [ convert-form map ] map ] [ % cond ] bake ;
: convert-general-form ( s-exp -- quot )
- unclip swap convert-body [ % , funcall ] bake ;
+ unclip convert-form swap convert-body [ , % funcall ] bake ;
<PRIVATE
: localize-body ( vars body -- newbody )
[ dup lisp-symbol? [ tuck name>> swap member? [ name>> make-local ] [ ] if ]
- [ dup s-exp? [ body>> localize-body <s-exp> ] [ nip ] if ] if ] with map ;
-PRIVATE>
+ [ dup s-exp? [ body>> localize-body <s-exp> ] [ nip ] if ] if
+ ] with map ;
+
+: localize-lambda ( body vars -- newbody newvars )
+ dup make-locals dup push-locals [ swap localize-body <s-exp> convert-form ] dipd
+ pop-locals swap ;
+
+PRIVATE>
+
+: split-lambda ( s-exp -- body vars )
+ first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline
+
+: rest-lambda-vars ( seq -- n newseq )
+ "&rest" swap [ remove ] [ index ] 2bi ;
: convert-lambda ( s-exp -- quot )
- first3 -rot nip [ body>> ] bi@ reverse [ name>> ] map dup make-locals dup push-locals
- [ swap localize-body convert-body ] dipd pop-locals swap <lambda> ;
+ split-lambda dup "&rest" swap member? [ rest-lambda-vars ] [ dup length ] if
+ [ localize-lambda <lambda> ] dip
+ [ , cut [ dup length firstn ] dip dup empty? [ drop ] when , with-locals ] bake ;
: convert-quoted ( s-exp -- quot )
second [ , ] bake ;
@@ -56,17 +70,19 @@ PRIVATE>
: lisp-string>factor ( str -- quot )
lisp-expr parse-result-ast convert-form ;
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-SYMBOL: lisp-env
+SYMBOL: lisp-env
-H{ } clone lisp-env set
+: init-env ( -- )
+ H{ } clone lisp-env set ;
-: define-lisp-word ( name body -- )
- lisp-env get set-at ;
+: lisp-define ( name quot -- )
+ swap lisp-env get set-at ;
-: get-lisp-word ( name -- word )
+: lisp-get ( name -- word )
lisp-env get at ;
-: funcall ( quot sym -- * )
- name>> get-lisp-word call ;
\ No newline at end of file
+: funcall ( quot sym -- * )
+ dup lisp-symbol? [ name>> lisp-get ] when call ; inline
\ No newline at end of file
From 2e796f84310ec681d9f0f6e9f62d1c30d68abb81 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <microdan@gmail.com>
Date: Tue, 6 May 2008 16:26:20 -0500
Subject: [PATCH 23/41] Interval maps made more efficient
---
extra/interval-maps/interval-maps.factor | 30 ++++++++++++++----------
extra/unicode/breaks/breaks.factor | 0
2 files changed, 17 insertions(+), 13 deletions(-)
mode change 100644 => 100755 extra/unicode/breaks/breaks.factor
diff --git a/extra/interval-maps/interval-maps.factor b/extra/interval-maps/interval-maps.factor
index 7dcb9466cc..bc46fd986b 100755
--- a/extra/interval-maps/interval-maps.factor
+++ b/extra/interval-maps/interval-maps.factor
@@ -1,36 +1,40 @@
-USING: kernel sequences arrays math.intervals accessors
+USING: kernel sequences arrays accessors
math.order sorting math assocs locals namespaces ;
IN: interval-maps
TUPLE: interval-map array ;
<PRIVATE
-TUPLE: interval-node interval value ;
+TUPLE: interval-node from to value ;
+: range ( node -- from to ) [ from>> ] [ to>> ] bi ;
: fixup-value ( value ? -- value/f ? )
[ drop f f ] unless* ;
: find-interval ( key interval-map -- i )
- [ interval>> from>> first <=> ] binsearch ;
+ [ from>> <=> ] binsearch ;
-GENERIC: >interval ( object -- interval )
-M: number >interval [a,a] ;
-M: sequence >interval first2 [a,b] ;
-M: interval >interval ;
+GENERIC: >interval ( object -- 2array )
+M: number >interval dup 2array ;
+M: sequence >interval ;
: all-intervals ( sequence -- intervals )
[ >r >interval r> ] assoc-map ;
+: disjoint? ( node1 node2 -- ? )
+ [ to>> ] [ from>> ] bi* < ;
+
: ensure-disjoint ( intervals -- intervals )
- dup keys [ interval-intersect not ] monotonic?
+ dup [ disjoint? ] monotonic?
[ "Intervals are not disjoint" throw ] unless ;
-
+: interval-contains? ( object interval-node -- ? )
+ range between? ;
PRIVATE>
: interval-at* ( key map -- value ? )
array>> [ find-interval ] 2keep swapd nth
- [ nip value>> ] [ interval>> interval-contains? ] 2bi
+ [ nip value>> ] [ interval-contains? ] 2bi
fixup-value ;
: interval-at ( key map -- value ) interval-at* drop ;
@@ -38,9 +42,9 @@ PRIVATE>
: <interval-map> ( specification -- map )
all-intervals { } assoc-like
- [ [ first to>> ] compare ] sort ensure-disjoint
- [ interval-node boa ] { } assoc>map
- interval-map boa ;
+ [ [ first second ] compare ] sort
+ [ >r first2 r> interval-node boa ] { } assoc>map
+ ensure-disjoint interval-map boa ;
:: coalesce ( alist -- specification )
! Only works with integer keys, because they're discrete
diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor
old mode 100644
new mode 100755
From c04da7bdfb0874515ee146e96cda042e0c63b00a Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <microdan@gmail.com>
Date: Tue, 6 May 2008 20:59:37 -0500
Subject: [PATCH 24/41] unicode.syntax.backend => value (with docs &c)
---
extra/io/encodings/iana/iana.factor | 6 ++---
extra/unicode/breaks/breaks.factor | 4 +--
extra/unicode/data/data.factor | 2 +-
extra/unicode/script/script.factor | 2 +-
extra/values/authors.txt | 1 +
extra/values/summary.txt | 1 +
extra/values/tags.txt | 1 +
extra/values/values-docs.factor | 27 +++++++++++++++++++
extra/values/values-tests.factor | 9 +++++++
.../backend.factor => values/values.factor} | 8 +++++-
10 files changed, 53 insertions(+), 8 deletions(-)
mode change 100644 => 100755 extra/io/encodings/iana/iana.factor
create mode 100755 extra/values/authors.txt
create mode 100755 extra/values/summary.txt
create mode 100755 extra/values/tags.txt
create mode 100755 extra/values/values-docs.factor
create mode 100755 extra/values/values-tests.factor
rename extra/{unicode/syntax/backend/backend.factor => values/values.factor} (52%)
mode change 100644 => 100755
diff --git a/extra/io/encodings/iana/iana.factor b/extra/io/encodings/iana/iana.factor
old mode 100644
new mode 100755
index 24badaf683..dd429c1670
--- a/extra/io/encodings/iana/iana.factor
+++ b/extra/io/encodings/iana/iana.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2008 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel strings unicode.syntax.backend io.files assocs
-splitting sequences io namespaces sets
-io.encodings.ascii io.encodings.utf8 io.encodings.utf16 io.encodings.8-bit ;
+USING: kernel strings values io.files assocs
+splitting sequences io namespaces sets io.encodings.8-bit
+io.encodings.ascii io.encodings.utf8 io.encodings.utf16 ;
IN: io.encodings.iana
<PRIVATE
diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor
index d8e4f8c24e..3787f78648 100755
--- a/extra/unicode/breaks/breaks.factor
+++ b/extra/unicode/breaks/breaks.factor
@@ -1,7 +1,7 @@
USING: unicode.categories kernel math combinators splitting
sequences math.parser io.files io assocs arrays namespaces
-math.ranges unicode.normalize unicode.syntax.backend
-unicode.syntax unicode.data compiler.units alien.syntax io.encodings.ascii ;
+math.ranges unicode.normalize values io.encodings.ascii
+unicode.syntax unicode.data compiler.units alien.syntax ;
IN: unicode.breaks
C-ENUM: Any L V T Extend Control CR LF graphemes ;
diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor
index 85ce50acb9..d630aacbed 100755
--- a/extra/unicode/data/data.factor
+++ b/extra/unicode/data/data.factor
@@ -1,7 +1,7 @@
USING: assocs math kernel sequences io.files hashtables
quotations splitting arrays math.parser hash2 math.order
byte-arrays words namespaces words compiler.units parser
-io.encodings.ascii unicode.syntax.backend ;
+io.encodings.ascii values ;
IN: unicode.data
! Convenience functions
diff --git a/extra/unicode/script/script.factor b/extra/unicode/script/script.factor
index d0bb4ac30d..846f797f71 100755
--- a/extra/unicode/script/script.factor
+++ b/extra/unicode/script/script.factor
@@ -1,4 +1,4 @@
-USING: unicode.syntax.backend kernel sequences assocs io.files
+USING: values kernel sequences assocs io.files
io.encodings ascii math.ranges io splitting math.parser
namespaces byte-arrays locals math sets io.encodings.ascii
words compiler.units arrays interval-maps ;
diff --git a/extra/values/authors.txt b/extra/values/authors.txt
new file mode 100755
index 0000000000..504363d316
--- /dev/null
+++ b/extra/values/authors.txt
@@ -0,0 +1 @@
+Daniel Ehrenberg
diff --git a/extra/values/summary.txt b/extra/values/summary.txt
new file mode 100755
index 0000000000..7caab7412d
--- /dev/null
+++ b/extra/values/summary.txt
@@ -0,0 +1 @@
+Global variables in the Forth value style
diff --git a/extra/values/tags.txt b/extra/values/tags.txt
new file mode 100755
index 0000000000..187b6926c1
--- /dev/null
+++ b/extra/values/tags.txt
@@ -0,0 +1 @@
+extensions
diff --git a/extra/values/values-docs.factor b/extra/values/values-docs.factor
new file mode 100755
index 0000000000..4984b03f03
--- /dev/null
+++ b/extra/values/values-docs.factor
@@ -0,0 +1,27 @@
+USING: help.markup help.syntax ;
+IN: values
+
+ARTICLE: "values" "Global values"
+"Usually, dynamically scoped variables are sufficient for holding data which is not literal. But occasionally, for global information that's calculated just once, it's useful to use the word mechanism instead, and set the word to the appropriate value just once. Values abstract over this concept. To create a new word as a value, use the following syntax:"
+{ $subsection POSTPONE: VALUE: }
+"To get the value, just call the word. The following words manipulate values:"
+{ $subsection get-value }
+{ $subsection set-value }
+{ $subsection change-value } ;
+
+HELP: VALUE:
+{ $syntax "VALUE: word" }
+{ $values { "word" "a word to be created" } }
+{ $description "Creates a value on the given word, initializing it to hold " { $code f } ". To get the value, just run the word. To set it, use " { $link set-value } "." } ;
+
+HELP: get-value
+{ $values { "word" "a value word" } { "value" "the contents" } }
+{ $description "Gets a value. This should not normally be used, unless the word is not known until runtime." } ;
+
+HELP: set-value
+{ $values { "value" "a new value" } { "word" "a value word" } }
+{ $description "Sets the value word." } ;
+
+HELP: change-value
+{ $values { "word" "a value word" } { "quot" "a quotation ( oldvalue -- newvalue )" } }
+{ $description "Changes the value using the given quotation." } ;
diff --git a/extra/values/values-tests.factor b/extra/values/values-tests.factor
new file mode 100755
index 0000000000..31b44be99e
--- /dev/null
+++ b/extra/values/values-tests.factor
@@ -0,0 +1,9 @@
+USING: tools.test values math ;
+IN: values.tests
+
+VALUE: foo
+[ f ] [ foo ] unit-test
+[ ] [ 3 \ foo set-value ] unit-test
+[ 3 ] [ foo ] unit-test
+[ ] [ \ foo [ 1+ ] change-value ] unit-test
+[ 4 ] [ foo ] unit-test
diff --git a/extra/unicode/syntax/backend/backend.factor b/extra/values/values.factor
old mode 100644
new mode 100755
similarity index 52%
rename from extra/unicode/syntax/backend/backend.factor
rename to extra/values/values.factor
index 5c463e8fc4..0d1ea3bc04
--- a/extra/unicode/syntax/backend/backend.factor
+++ b/extra/values/values.factor
@@ -1,8 +1,14 @@
USING: kernel parser sequences words ;
-IN: unicode.syntax.backend
+IN: values
: VALUE:
CREATE-WORD { f } clone [ first ] curry define ; parsing
: set-value ( value word -- )
word-def first set-first ;
+
+: get-value ( word -- value )
+ word-def first first ;
+
+: change-value ( word quot -- )
+ over >r >r get-value r> call r> set-value ; inline
From a233349c1f95be8d8079d37fbca71b1e9ac6278b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 9 May 2008 00:09:12 -0500
Subject: [PATCH 25/41] Bigger cards and decks
---
core/compiler/constants/constants.factor | 4 ++--
vm/data_gc.c | 14 ++++++++------
vm/data_gc.h | 13 +++++--------
3 files changed, 15 insertions(+), 16 deletions(-)
diff --git a/core/compiler/constants/constants.factor b/core/compiler/constants/constants.factor
index 9594cf7b23..8610f490ec 100755
--- a/core/compiler/constants/constants.factor
+++ b/core/compiler/constants/constants.factor
@@ -4,8 +4,8 @@ USING: math kernel layouts system ;
IN: compiler.constants
! These constants must match vm/memory.h
-: card-bits 6 ;
-: deck-bits 12 ;
+: card-bits 8 ;
+: deck-bits 18 ;
: card-mark HEX: 40 HEX: 80 bitor ;
! These constants must match vm/layouts.h
diff --git a/vm/data_gc.c b/vm/data_gc.c
index f44b8a7a05..c12c65aaff 100755
--- a/vm/data_gc.c
+++ b/vm/data_gc.c
@@ -59,6 +59,8 @@ F_DATA_HEAP *alloc_data_heap(CELL gens,
return NULL; /* can't happen */
}
+ total_size += DECK_SIZE;
+
data_heap->segment = alloc_segment(total_size);
data_heap->generations = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
@@ -75,7 +77,7 @@ F_DATA_HEAP *alloc_data_heap(CELL gens,
data_heap->decks = safe_malloc(decks_size);
data_heap->decks_end = data_heap->decks + decks_size;
- CELL alloter = data_heap->segment->start;
+ CELL alloter = (data_heap->segment->start + DECK_SIZE - 1) & ~(DECK_SIZE - 1);
alloter = init_zone(&data_heap->generations[TENURED],tenured_size,alloter);
alloter = init_zone(&data_heap->semispaces[TENURED],tenured_size,alloter);
@@ -92,7 +94,7 @@ F_DATA_HEAP *alloc_data_heap(CELL gens,
alloter = init_zone(&data_heap->semispaces[NURSERY],0,alloter);
}
- if(alloter != data_heap->segment->end)
+ if(data_heap->segment->end - alloter > DECK_SIZE)
critical_error("Bug in alloc_data_heap",alloter);
return data_heap;
@@ -163,6 +165,10 @@ void gc_reset(void)
int i;
for(i = 0; i < MAX_GEN_COUNT; i++)
memset(&gc_stats[i],0,sizeof(F_GC_STATS));
+
+ cards_scanned = 0;
+ decks_scanned = 0;
+ code_heap_scans = 0;
}
void init_data_heap(CELL gens,
@@ -182,10 +188,6 @@ void init_data_heap(CELL gens,
secure_gc = secure_gc_;
gc_reset();
-
- cards_scanned = 0;
- decks_scanned = 0;
- code_heap_scans = 0;
}
/* Size of the object pointed to by a tagged pointer */
diff --git a/vm/data_gc.h b/vm/data_gc.h
index 20692c14e6..301821bb7a 100755
--- a/vm/data_gc.h
+++ b/vm/data_gc.h
@@ -68,13 +68,11 @@ the offset of the first object is set by the allocator. */
#define CARD_POINTS_TO_NURSERY 0x80
#define CARD_POINTS_TO_AGING 0x40
#define CARD_MARK_MASK (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING)
-#define CARD_BASE_MASK 0x3f
+#define CARD_BASE_MASK 0xff
typedef u8 F_CARD;
-/* A card is 64 bytes. 6 bits is sufficient to represent every
-offset within the card */
-#define CARD_SIZE 64
-#define CARD_BITS 6
+#define CARD_BITS 8
+#define CARD_SIZE (1<<CARD_BITS)
#define ADDR_CARD_MASK (CARD_SIZE-1)
DLLEXPORT CELL cards_offset;
@@ -83,11 +81,10 @@ DLLEXPORT CELL allot_markers_offset;
#define ADDR_TO_CARD(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + cards_offset)
#define CARD_TO_ADDR(c) (CELL*)(((CELL)(c) - cards_offset)<<CARD_BITS)
-/* A deck is 4 kilobytes or 64 cards. */
typedef u8 F_DECK;
-#define DECK_SIZE (4 * 1024)
-#define DECK_BITS 12
+#define DECK_BITS (CARD_BITS + 10)
+#define DECK_SIZE (1<<DECK_BITS)
#define ADDR_DECK_MASK (DECK_SIZE-1)
DLLEXPORT CELL decks_offset;
From 347ba14bd1f7aa23c3d1ceb59bb4152654f8a84f Mon Sep 17 00:00:00 2001
From: Alex Chapman <chapman.alex@gmail.com>
Date: Fri, 9 May 2008 16:47:13 +1000
Subject: [PATCH 26/41] jamshred: bounce 0.1 away from the wall so we don't see
through it
---
extra/jamshred/gl/gl.factor | 12 ++++--------
extra/jamshred/tunnel/tunnel.factor | 4 +++-
2 files changed, 7 insertions(+), 9 deletions(-)
diff --git a/extra/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor
index 85c5a8dbaf..58e2b1f882 100644
--- a/extra/jamshred/gl/gl.factor
+++ b/extra/jamshred/gl/gl.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types colors jamshred.game jamshred.oint
+USING: accessors alien.c-types colors jamshred.game jamshred.oint
jamshred.player jamshred.tunnel kernel math math.vectors opengl
opengl.gl opengl.glu sequences ;
IN: jamshred.gl
@@ -37,10 +37,6 @@ IN: jamshred.gl
: draw-tunnel ( player -- )
segments-to-render draw-segments ;
-! : draw-tunnel ( player tunnel -- )
-! tuck swap player-nearest-segment segment-number dup n-segments-behind -
-! swap n-segments-ahead + rot sub-tunnel draw-segments ;
-
: init-graphics ( width height -- )
GL_DEPTH_TEST glEnable
GL_SCISSOR_TEST glDisable
@@ -63,9 +59,9 @@ IN: jamshred.gl
GL_LIGHT0 GL_SPECULAR F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv ;
: player-view ( player -- )
- [ oint-location first3 ] keep
- [ dup oint-location swap oint-forward v+ first3 ] keep
- oint-up first3 gluLookAt ;
+ [ location>> first3 ]
+ [ [ location>> ] [ forward>> ] bi v+ first3 ]
+ [ up>> first3 ] tri gluLookAt ;
: draw-jamshred ( jamshred width height -- )
init-graphics jamshred-player dup player-view draw-tunnel ;
diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor
index 139cdbfb53..f3fa9a0354 100755
--- a/extra/jamshred/tunnel/tunnel.factor
+++ b/extra/jamshred/tunnel/tunnel.factor
@@ -127,7 +127,9 @@ C: <segment> segment
[ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
: collision-vector ( oint segment -- v )
- [ sideways-heading ] [ sideways-relative-location ] [ radius>> ] 2tri
+ [ sideways-heading ] [ sideways-relative-location ]
+ [ radius>> 0.1 - ] ! bounce before we hit so that we can't see through the wall (hack?)
+ 2tri
swap [ collision-coefficient ] dip forward>> n*v ;
: distance-to-collision ( oint segment -- distance )
From 1005e5e9395aa3406f1742c404fa318c75b79158 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <microdan@gmail.com>
Date: Fri, 9 May 2008 15:42:02 -0500
Subject: [PATCH 27/41] Minor refactoring in lcs and interval-maps
---
extra/interval-maps/interval-maps.factor | 22 ++++++++++------------
extra/lcs/lcs.factor | 9 ++++-----
2 files changed, 14 insertions(+), 17 deletions(-)
diff --git a/extra/interval-maps/interval-maps.factor b/extra/interval-maps/interval-maps.factor
index bc46fd986b..904b76ce94 100755
--- a/extra/interval-maps/interval-maps.factor
+++ b/extra/interval-maps/interval-maps.factor
@@ -1,4 +1,4 @@
-USING: kernel sequences arrays accessors
+USING: kernel sequences arrays accessors tuple-arrays
math.order sorting math assocs locals namespaces ;
IN: interval-maps
@@ -6,7 +6,6 @@ TUPLE: interval-map array ;
<PRIVATE
TUPLE: interval-node from to value ;
-: range ( node -- from to ) [ from>> ] [ to>> ] bi ;
: fixup-value ( value ? -- value/f ? )
[ drop f f ] unless* ;
@@ -14,12 +13,12 @@ TUPLE: interval-node from to value ;
: find-interval ( key interval-map -- i )
[ from>> <=> ] binsearch ;
-GENERIC: >interval ( object -- 2array )
-M: number >interval dup 2array ;
-M: sequence >interval ;
+: interval-contains? ( object interval-node -- ? )
+ [ from>> ] [ to>> ] bi between? ;
: all-intervals ( sequence -- intervals )
- [ >r >interval r> ] assoc-map ;
+ [ >r dup number? [ dup 2array ] when r> ] assoc-map
+ { } assoc-like ;
: disjoint? ( node1 node2 -- ? )
[ to>> ] [ from>> ] bi* < ;
@@ -28,8 +27,8 @@ M: sequence >interval ;
dup [ disjoint? ] monotonic?
[ "Intervals are not disjoint" throw ] unless ;
-: interval-contains? ( object interval-node -- ? )
- range between? ;
+: >intervals ( specification -- intervals )
+ [ >r first2 r> interval-node boa ] { } assoc>map ;
PRIVATE>
: interval-at* ( key map -- value ? )
@@ -41,10 +40,9 @@ PRIVATE>
: interval-key? ( key map -- ? ) interval-at* nip ;
: <interval-map> ( specification -- map )
- all-intervals { } assoc-like
- [ [ first second ] compare ] sort
- [ >r first2 r> interval-node boa ] { } assoc>map
- ensure-disjoint interval-map boa ;
+ all-intervals [ [ first second ] compare ] sort
+ >intervals ensure-disjoint >tuple-array
+ interval-map boa ;
:: coalesce ( alist -- specification )
! Only works with integer keys, because they're discrete
diff --git a/extra/lcs/lcs.factor b/extra/lcs/lcs.factor
index cdebfc4325..e5155a786e 100755
--- a/extra/lcs/lcs.factor
+++ b/extra/lcs/lcs.factor
@@ -7,7 +7,7 @@ IN: lcs
0 1 ? + >r [ 1+ ] bi@ r> min min ;
: lcs-step ( insert delete change same? -- next )
- 1 -9999 ? + max max ; ! Replace -9999 with -inf when added
+ 1 -1./0. ? + max max ; ! -1./0. is -inf (float)
:: loop-step ( i j matrix old new step -- )
i j 1+ matrix nth nth ! insertion
@@ -25,10 +25,9 @@ IN: lcs
:: run-lcs ( old new init step -- matrix )
[let | matrix [ old length 1+ new length 1+ init call ] |
- old length [0,b) [| i |
- new length [0,b)
- [| j | i j matrix old new step loop-step ]
- each
+ old length [| i |
+ new length
+ [| j | i j matrix old new step loop-step ] each
] each matrix ] ; inline
PRIVATE>
From 0cd8e61f24ed5d074682961aa5c098a40e75aec4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 9 May 2008 16:38:27 -0500
Subject: [PATCH 28/41] Streams fixes
---
core/io/streams/string/string.factor | 5 +----
extra/delegate/protocols/protocols.factor | 5 +++--
extra/io/streams/duplex/duplex-tests.factor | 8 +++++++-
3 files changed, 11 insertions(+), 7 deletions(-)
diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor
index d43599776b..bcad667c60 100755
--- a/core/io/streams/string/string.factor
+++ b/core/io/streams/string/string.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel math namespaces sequences sbufs strings
generic splitting growable continuations io.streams.plain
-io.encodings io.encodings.private math.order ;
+io.encodings math.order ;
IN: io.streams.string
M: growable dispose drop ;
@@ -77,6 +77,3 @@ M: plain-writer stream-write-table
[ drop format-table [ print ] each ] with-output-stream* ;
M: plain-writer make-cell-stream 2drop <string-writer> ;
-
-M: growable stream-readln ( stream -- str )
- "\r\n" over stream-read-until handle-readln ;
diff --git a/extra/delegate/protocols/protocols.factor b/extra/delegate/protocols/protocols.factor
index c1d7e1e4ab..d4d34f0bd0 100755
--- a/extra/delegate/protocols/protocols.factor
+++ b/extra/delegate/protocols/protocols.factor
@@ -13,11 +13,12 @@ PROTOCOL: assoc-protocol
delete-at clear-assoc new-assoc assoc-like ;
PROTOCOL: input-stream-protocol
- stream-read1 stream-read stream-read-until stream-read-quot ;
+ stream-read1 stream-read stream-read-partial stream-readln
+ stream-read-until stream-read-quot ;
PROTOCOL: output-stream-protocol
stream-flush stream-write1 stream-write stream-format
- stream-nl make-span-stream make-block-stream stream-readln
+ stream-nl make-span-stream make-block-stream
make-cell-stream stream-write-table ;
PROTOCOL: definition-protocol
diff --git a/extra/io/streams/duplex/duplex-tests.factor b/extra/io/streams/duplex/duplex-tests.factor
index ebc6b3be1f..9377256c0d 100755
--- a/extra/io/streams/duplex/duplex-tests.factor
+++ b/extra/io/streams/duplex/duplex-tests.factor
@@ -1,4 +1,5 @@
-USING: io.streams.duplex io kernel continuations tools.test ;
+USING: io.streams.duplex io io.streams.string
+kernel continuations tools.test ;
IN: io.streams.duplex.tests
! Test duplex stream close behavior
@@ -38,3 +39,8 @@ M: unclosable-stream dispose
[ dup dispose ] [ 2drop ] recover
] keep closing-stream-closed?
] unit-test
+
+[ "Hey" ] [
+ "Hey\nThere" <string-reader> <string-writer> <duplex-stream>
+ stream-readln
+] unit-test
From 30c7f560c115ca2554f47b0fbbb24e69badde282 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 9 May 2008 16:46:24 -0500
Subject: [PATCH 29/41] Add unit test for Ed's touch-file fix
---
core/io/files/files-tests.factor | 9 ++++++++-
extra/io/unix/files/files.factor | 7 +++----
2 files changed, 11 insertions(+), 5 deletions(-)
diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor
index a463fd2e40..84b0bd3e09 100755
--- a/core/io/files/files-tests.factor
+++ b/core/io/files/files-tests.factor
@@ -1,7 +1,7 @@
IN: io.files.tests
USING: tools.test io.files io.files.private io threads kernel
continuations io.encodings.ascii io.files.unique sequences
-strings accessors io.encodings.utf8 ;
+strings accessors io.encodings.utf8 math ;
[ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test
[ ] [ "blahblah" temp-file make-directory ] unit-test
@@ -43,6 +43,8 @@ strings accessors io.encodings.utf8 ;
"file4" temp-file delete-file
] unit-test
+[ "file5" temp-file delete-file ] ignore-errors
+
[ ] [
temp-directory [
"file5" touch-file
@@ -50,6 +52,8 @@ strings accessors io.encodings.utf8 ;
] with-directory
] unit-test
+[ "file6" temp-file delete-file ] ignore-errors
+
[ ] [
temp-directory [
"file6" touch-file
@@ -259,3 +263,6 @@ strings accessors io.encodings.utf8 ;
[ t ] [ "resource:core" absolute-path? ] unit-test
[ f ] [ "" absolute-path? ] unit-test
+
+[ "touch-twice-test" temp-file delete-file ] ignore-errors
+[ ] [ 2 [ "touch-twice-test" temp-file touch-file ] times ] unit-test
diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor
index b361974a20..28e08d4bf2 100755
--- a/extra/io/unix/files/files.factor
+++ b/extra/io/unix/files/files.factor
@@ -45,10 +45,9 @@ M: unix (file-appender) ( path -- stream )
M: unix touch-file ( path -- )
normalize-path
- dup exists?
- [ f utime ]
- [ touch-mode file-mode open close ]
- if ;
+ dup exists? [ f utime ] [
+ touch-mode file-mode open close
+ ] if ;
M: unix move-file ( from to -- )
[ normalize-path ] bi@ rename io-error ;
From 57a86605d8d264c138ec63fbeab115707baaf850 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 9 May 2008 17:11:10 -0500
Subject: [PATCH 30/41] Fix deployment on Mac OS X
---
extra/tools/deploy/shaker/strip-cocoa.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/tools/deploy/shaker/strip-cocoa.factor b/extra/tools/deploy/shaker/strip-cocoa.factor
index 038bfde70d..0c77a52f94 100755
--- a/extra/tools/deploy/shaker/strip-cocoa.factor
+++ b/extra/tools/deploy/shaker/strip-cocoa.factor
@@ -1,6 +1,6 @@
USING: cocoa cocoa.messages cocoa.application cocoa.nibs
assocs namespaces kernel words compiler.units sequences
-ui.cocoa ;
+ui ui.cocoa ;
"stop-after-last-window?" get
global [
From 412caee9e9c21e7c624128e8cd42b3c1b254d4d0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 9 May 2008 17:11:20 -0500
Subject: [PATCH 31/41] Tweak SMTP test for threading changes
---
extra/smtp/smtp-tests.factor | 6 +++++-
1 file changed, 5 insertions(+), 1 deletion(-)
diff --git a/extra/smtp/smtp-tests.factor b/extra/smtp/smtp-tests.factor
index 162512f9f3..5d350d80c4 100755
--- a/extra/smtp/smtp-tests.factor
+++ b/extra/smtp/smtp-tests.factor
@@ -68,7 +68,9 @@ IN: smtp.tests
rot from>>
] unit-test
-[ ] [ [ 4321 mock-smtp-server ] in-thread ] unit-test
+[ ] [ [ 4321 mock-smtp-server ] "SMTP server" spawn drop ] unit-test
+
+[ ] [ yield ] unit-test
[ ] [
[
@@ -85,3 +87,5 @@ IN: smtp.tests
send-email
] with-scope
] unit-test
+
+[ ] [ yield ] unit-test
From c6bf45c07d597372f1388db597924e4e1e5f2c87 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 9 May 2008 17:11:30 -0500
Subject: [PATCH 32/41] Stylistic change
---
core/words/words.factor | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/core/words/words.factor b/core/words/words.factor
index 138b1ef928..b640cc6384 100755
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -136,9 +136,9 @@ SYMBOL: visited
[ reset-on-redefine reset-props ]
[ dup visited get set-at ]
[
- crossref get at keys [ word? ] filter [
- reset-on-redefine [ word-prop ] with contains?
- ] filter
+ crossref get at keys
+ [ word? ] filter
+ [ reset-on-redefine [ word-prop ] with contains? ] filter
[ (redefined) ] each
] tri
] if ;
From d4258444855deae13d0a091d605678d9b88f7b49 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 9 May 2008 17:11:46 -0500
Subject: [PATCH 33/41] Fix bootstrap without compiler being loaded
---
core/bootstrap/image/image.factor | 2 --
core/bootstrap/primitives.factor | 2 ++
core/bootstrap/stage1.factor | 2 ++
3 files changed, 4 insertions(+), 2 deletions(-)
diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor
index 1ff04bacc2..aa7377adbf 100755
--- a/core/bootstrap/image/image.factor
+++ b/core/bootstrap/image/image.factor
@@ -482,8 +482,6 @@ PRIVATE>
: make-image ( arch -- )
[
architecture set
- bootstrapping? on
- load-help? off
"resource:/core/bootstrap/stage1.factor" run-file
build-image
write-image
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 3ce783d620..31ba4e4b6d 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -51,6 +51,8 @@ call
! After we execute bootstrap/layouts
num-types get f <array> builtins set
+bootstrapping? on
+
! Create some empty vocabs where the below primitives and
! classes will go
{
diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor
index f99c8eb82f..64402ca2e1 100755
--- a/core/bootstrap/stage1.factor
+++ b/core/bootstrap/stage1.factor
@@ -13,6 +13,8 @@ vocabs.loader system debugger continuations ;
"resource:core/bootstrap/primitives.factor" run-file
+load-help? off
+
! Create a boot quotation for the target
[
[
From 4ffac018a1cb9c155907652037a591beb05e4c55 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 9 May 2008 17:14:26 -0500
Subject: [PATCH 34/41] More robust threads test
---
core/threads/threads-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/threads/threads-tests.factor b/core/threads/threads-tests.factor
index 0e33ccd94c..122b7f1d59 100755
--- a/core/threads/threads-tests.factor
+++ b/core/threads/threads-tests.factor
@@ -4,7 +4,7 @@ words ;
IN: threads.tests
3 "x" set
-namespace [ [ yield 2 "x" set ] bind ] curry "Test" spawn drop
+[ 2 "x" set ] "Test" spawn drop
[ 2 ] [ yield "x" get ] unit-test
[ ] [ [ flush ] "flush test" spawn drop flush ] unit-test
[ ] [ [ "Errors, errors" throw ] "error test" spawn drop ] unit-test
From c035f86ca28865921a0cbccf82651197d8031574 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 9 May 2008 17:30:32 -0500
Subject: [PATCH 35/41] Revert large deck change for now, fix PowerPC write
barrier
---
core/compiler/constants/constants.factor | 4 ++--
core/cpu/ppc/intrinsics/intrinsics.factor | 6 +++---
vm/data_gc.c | 25 +++++++++++++----------
vm/data_gc.h | 21 +++++++++----------
vm/run.h | 6 +++---
5 files changed, 32 insertions(+), 30 deletions(-)
diff --git a/core/compiler/constants/constants.factor b/core/compiler/constants/constants.factor
index 8610f490ec..9594cf7b23 100755
--- a/core/compiler/constants/constants.factor
+++ b/core/compiler/constants/constants.factor
@@ -4,8 +4,8 @@ USING: math kernel layouts system ;
IN: compiler.constants
! These constants must match vm/memory.h
-: card-bits 8 ;
-: deck-bits 18 ;
+: card-bits 6 ;
+: deck-bits 12 ;
: card-mark HEX: 40 HEX: 80 bitor ;
! These constants must match vm/layouts.h
diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor
index d85c70577e..ac59deb8bb 100755
--- a/core/cpu/ppc/intrinsics/intrinsics.factor
+++ b/core/cpu/ppc/intrinsics/intrinsics.factor
@@ -66,12 +66,12 @@ IN: cpu.ppc.intrinsics
! Mark the card
"val" operand load-cards-offset
"obj" operand "scratch2" operand card-bits SRWI
- "val" operand "scratch2" operand "val" operand STBX
+ "scratch1" operand "scratch2" operand "val" operand STBX
! Mark the card deck
"val" operand load-decks-offset
- "obj" operand "scratch" operand deck-bits SRWI
- "val" operand "scratch" operand "val" operand STBX
+ "obj" operand "scratch2" operand deck-bits SRWI
+ "scratch1" operand "scratch2" operand "val" operand STBX
] unless ;
\ set-slot {
diff --git a/vm/data_gc.c b/vm/data_gc.c
index c12c65aaff..9a39642cde 100755
--- a/vm/data_gc.c
+++ b/vm/data_gc.c
@@ -7,6 +7,8 @@
#define END_AGING_GC "end_gc: aging_collections=%ld, cards_scanned=%ld\n"
#define END_NURSERY_GC "end_gc: nursery_collections=%ld, cards_scanned=%ld\n"
+/* #define GC_DEBUG */
+
#ifdef GC_DEBUG
#define GC_PRINT printf
#else
@@ -23,7 +25,7 @@ CELL init_zone(F_ZONE *z, CELL size, CELL start)
void init_card_decks(void)
{
- CELL start = data_heap->segment->start & ~(DECK_SIZE - 1);
+ CELL start = align(data_heap->segment->start,DECK_SIZE);
allot_markers_offset = (CELL)data_heap->allot_markers - (start >> CARD_BITS);
cards_offset = (CELL)data_heap->cards - (start >> CARD_BITS);
decks_offset = (CELL)data_heap->decks - (start >> DECK_BITS);
@@ -66,18 +68,18 @@ F_DATA_HEAP *alloc_data_heap(CELL gens,
data_heap->generations = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
data_heap->semispaces = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
- CELL cards_size = (total_size + DECK_SIZE) / CARD_SIZE;
+ CELL cards_size = total_size >> CARD_BITS;
data_heap->allot_markers = safe_malloc(cards_size);
data_heap->allot_markers_end = data_heap->allot_markers + cards_size;
data_heap->cards = safe_malloc(cards_size);
data_heap->cards_end = data_heap->cards + cards_size;
- CELL decks_size = (total_size + DECK_SIZE) / DECK_SIZE;
+ CELL decks_size = total_size >> DECK_BITS;
data_heap->decks = safe_malloc(decks_size);
data_heap->decks_end = data_heap->decks + decks_size;
- CELL alloter = (data_heap->segment->start + DECK_SIZE - 1) & ~(DECK_SIZE - 1);
+ CELL alloter = align(data_heap->segment->start,DECK_SIZE);
alloter = init_zone(&data_heap->generations[TENURED],tenured_size,alloter);
alloter = init_zone(&data_heap->semispaces[TENURED],tenured_size,alloter);
@@ -121,8 +123,6 @@ void dealloc_data_heap(F_DATA_HEAP *data_heap)
free(data_heap);
}
-/* Every card stores the offset of the first object in that card, which must be
-cleared when a generation has been cleared */
void clear_cards(CELL from, CELL to)
{
/* NOTE: reverse order due to heap layout. */
@@ -135,9 +135,9 @@ void clear_cards(CELL from, CELL to)
void clear_decks(CELL from, CELL to)
{
/* NOTE: reverse order due to heap layout. */
- F_CARD *first_deck = ADDR_TO_CARD(data_heap->generations[to].start);
- F_CARD *last_deck = ADDR_TO_CARD(data_heap->generations[from].end);
- F_CARD *ptr;
+ F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[to].start);
+ F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[from].end);
+ F_DECK *ptr;
for(ptr = first_deck; ptr < last_deck; ptr++) *ptr = 0;
}
@@ -147,7 +147,7 @@ void clear_allot_markers(CELL from, CELL to)
F_CARD *first_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[to].start);
F_CARD *last_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[from].end);
F_CARD *ptr;
- for(ptr = first_card; ptr < last_card; ptr++) *ptr = CARD_BASE_MASK;
+ for(ptr = first_card; ptr < last_card; ptr++) *ptr = INVALID_ALLOT_MARKER;
}
void set_data_heap(F_DATA_HEAP *data_heap_)
@@ -330,8 +330,11 @@ void collect_card(F_CARD *ptr, CELL gen, CELL here)
{
CELL offset = CARD_OFFSET(ptr);
- if(offset != CARD_BASE_MASK)
+ if(offset != INVALID_ALLOT_MARKER)
{
+ if(offset & TAG_MASK)
+ critical_error("Bad card",(CELL)ptr);
+
CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + offset;
CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1);
diff --git a/vm/data_gc.h b/vm/data_gc.h
index 301821bb7a..30a4aee6ee 100755
--- a/vm/data_gc.h
+++ b/vm/data_gc.h
@@ -68,22 +68,20 @@ the offset of the first object is set by the allocator. */
#define CARD_POINTS_TO_NURSERY 0x80
#define CARD_POINTS_TO_AGING 0x40
#define CARD_MARK_MASK (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING)
-#define CARD_BASE_MASK 0xff
typedef u8 F_CARD;
-#define CARD_BITS 8
+#define CARD_BITS 6
#define CARD_SIZE (1<<CARD_BITS)
#define ADDR_CARD_MASK (CARD_SIZE-1)
DLLEXPORT CELL cards_offset;
-DLLEXPORT CELL allot_markers_offset;
#define ADDR_TO_CARD(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + cards_offset)
#define CARD_TO_ADDR(c) (CELL*)(((CELL)(c) - cards_offset)<<CARD_BITS)
typedef u8 F_DECK;
-#define DECK_BITS (CARD_BITS + 10)
+#define DECK_BITS (CARD_BITS + 6)
#define DECK_SIZE (1<<DECK_BITS)
#define ADDR_DECK_MASK (DECK_SIZE-1)
@@ -97,12 +95,14 @@ DLLEXPORT CELL decks_offset;
#define ADDR_TO_ALLOT_MARKER(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + allot_markers_offset)
#define CARD_OFFSET(c) (*((c) - (CELL)data_heap->cards + (CELL)data_heap->allot_markers))
+#define INVALID_ALLOT_MARKER 0xff
+
+DLLEXPORT CELL allot_markers_offset;
+
void init_card_decks(void);
-/* this is an inefficient write barrier. compiled definitions use a more
-efficient one hand-coded in assembly. the write barrier must be called
-any time we are potentially storing a pointer from an older generation
-to a younger one */
+/* the write barrier must be called any time we are potentially storing a
+pointer from an older generation to a younger one */
INLINE void write_barrier(CELL address)
{
*ADDR_TO_CARD(address) = CARD_MARK_MASK;
@@ -121,9 +121,8 @@ INLINE void set_slot(CELL obj, CELL slot, CELL value)
INLINE void allot_barrier(CELL address)
{
F_CARD *ptr = ADDR_TO_ALLOT_MARKER(address);
- F_CARD b = *ptr;
- F_CARD a = (address & ADDR_CARD_MASK);
- *ptr = (b < a ? b : a);
+ if(*ptr == INVALID_ALLOT_MARKER)
+ *ptr = (address & ADDR_CARD_MASK);
}
void clear_cards(CELL from, CELL to);
diff --git a/vm/run.h b/vm/run.h
index e2afb08525..cc980453cf 100755
--- a/vm/run.h
+++ b/vm/run.h
@@ -103,11 +103,11 @@ INLINE void bput(CELL where, CELL what)
INLINE CELL align(CELL a, CELL b)
{
- return (a + b) & ~b;
+ return (a + (b-1)) & ~(b-1);
}
-#define align8(a) align(a,7)
-#define align_page(a) align(a,getpagesize() - 1)
+#define align8(a) align(a,8)
+#define align_page(a) align(a,getpagesize())
/* Canonical T object. It's just a word */
CELL T;
From f42719aa983d7b9bc1fe7931952d715a2b759381 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Fri, 9 May 2008 18:24:41 -0500
Subject: [PATCH 36/41] Fix PowerPC write barrier for real
---
core/cpu/ppc/intrinsics/intrinsics.factor | 10 +++++-----
1 file changed, 5 insertions(+), 5 deletions(-)
diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor
index ac59deb8bb..fd9682aee7 100755
--- a/core/cpu/ppc/intrinsics/intrinsics.factor
+++ b/core/cpu/ppc/intrinsics/intrinsics.factor
@@ -61,17 +61,17 @@ IN: cpu.ppc.intrinsics
: %write-barrier ( -- )
"val" get operand-immediate? "obj" get fresh-object? or [
- "scratch1" operand card-mark LI
+ card-mark "scratch1" operand LI
! Mark the card
"val" operand load-cards-offset
"obj" operand "scratch2" operand card-bits SRWI
- "scratch1" operand "scratch2" operand "val" operand STBX
+ "scratch2" operand "scratch1" operand "val" operand STBX
! Mark the card deck
"val" operand load-decks-offset
"obj" operand "scratch2" operand deck-bits SRWI
- "scratch1" operand "scratch2" operand "val" operand STBX
+ "scratch2" operand "scratch1" operand "val" operand STBX
] unless ;
\ set-slot {
@@ -87,7 +87,7 @@ IN: cpu.ppc.intrinsics
{
[ %slot-literal-any-tag STW %write-barrier ] H{
{ +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
- { +scratch+ { { f "scratch" } } }
+ { +scratch+ { { f "scratch1" } { f "scratch2" } } }
{ +clobber+ { "val" } }
}
}
@@ -95,7 +95,7 @@ IN: cpu.ppc.intrinsics
{
[ %slot-any STWX %write-barrier ] H{
{ +input+ { { f "val" } { f "obj" } { f "n" } } }
- { +scratch+ { { f "scratch" } { f "offset" } } }
+ { +scratch+ { { f "scratch1" } { f "scratch2" } { f "offset" } } }
{ +clobber+ { "val" } }
}
}
From 8c8f5fdb2c15f0260399282e0e3ca035b17c17e7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 9 May 2008 18:48:48 -0500
Subject: [PATCH 37/41] Bigger decks and cards
---
core/compiler/constants/constants.factor | 4 ++--
vm/data_gc.h | 4 ++--
2 files changed, 4 insertions(+), 4 deletions(-)
diff --git a/core/compiler/constants/constants.factor b/core/compiler/constants/constants.factor
index 9594cf7b23..8610f490ec 100755
--- a/core/compiler/constants/constants.factor
+++ b/core/compiler/constants/constants.factor
@@ -4,8 +4,8 @@ USING: math kernel layouts system ;
IN: compiler.constants
! These constants must match vm/memory.h
-: card-bits 6 ;
-: deck-bits 12 ;
+: card-bits 8 ;
+: deck-bits 18 ;
: card-mark HEX: 40 HEX: 80 bitor ;
! These constants must match vm/layouts.h
diff --git a/vm/data_gc.h b/vm/data_gc.h
index 30a4aee6ee..3c21695c2c 100755
--- a/vm/data_gc.h
+++ b/vm/data_gc.h
@@ -70,7 +70,7 @@ the offset of the first object is set by the allocator. */
#define CARD_MARK_MASK (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING)
typedef u8 F_CARD;
-#define CARD_BITS 6
+#define CARD_BITS 8
#define CARD_SIZE (1<<CARD_BITS)
#define ADDR_CARD_MASK (CARD_SIZE-1)
@@ -81,7 +81,7 @@ DLLEXPORT CELL cards_offset;
typedef u8 F_DECK;
-#define DECK_BITS (CARD_BITS + 6)
+#define DECK_BITS (CARD_BITS + 10)
#define DECK_SIZE (1<<DECK_BITS)
#define ADDR_DECK_MASK (DECK_SIZE-1)
From f0fda2f48f26d2e6f36a33a1b20a7fa95b3d97f1 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Fri, 9 May 2008 18:50:31 -0500
Subject: [PATCH 38/41] Fix PPC intrinsics
---
core/cpu/ppc/intrinsics/intrinsics.factor | 12 ++++++------
1 file changed, 6 insertions(+), 6 deletions(-)
diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor
index fd9682aee7..1b28f7262e 100755
--- a/core/cpu/ppc/intrinsics/intrinsics.factor
+++ b/core/cpu/ppc/intrinsics/intrinsics.factor
@@ -18,13 +18,13 @@ IN: cpu.ppc.intrinsics
"obj" get operand-tag - ;
: %slot-literal-any-tag
- "obj" operand "scratch" operand %untag
- "val" operand "scratch" operand "n" get cells ;
+ "obj" operand "scratch1" operand %untag
+ "val" operand "scratch1" operand "n" get cells ;
: %slot-any
- "obj" operand "scratch" operand %untag
+ "obj" operand "scratch1" operand %untag
"offset" operand "n" operand 1 SRAWI
- "scratch" operand "val" operand "offset" operand ;
+ "scratch1" operand "val" operand "offset" operand ;
\ slot {
! Slot number is literal and the tag is known
@@ -39,7 +39,7 @@ IN: cpu.ppc.intrinsics
{
[ %slot-literal-any-tag LWZ ] H{
{ +input+ { { f "obj" } { [ small-slot? ] "n" } } }
- { +scratch+ { { f "scratch" } { f "val" } } }
+ { +scratch+ { { f "scratch1" } { f "val" } } }
{ +output+ { "val" } }
}
}
@@ -47,7 +47,7 @@ IN: cpu.ppc.intrinsics
{
[ %slot-any LWZX ] H{
{ +input+ { { f "obj" } { f "n" } } }
- { +scratch+ { { f "val" } { f "scratch" } { f "offset" } } }
+ { +scratch+ { { f "val" } { f "scratch1" } { f "offset" } } }
{ +output+ { "val" } }
}
}
From 95e22f6d8eea51ad7e01a5509b7ce5a20b40f453 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 9 May 2008 20:18:59 -0500
Subject: [PATCH 39/41] Fix load error; with-locals no longer exists
---
extra/lisp/lisp.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor
index 7630889570..7d4b9af02a 100644
--- a/extra/lisp/lisp.factor
+++ b/extra/lisp/lisp.factor
@@ -46,7 +46,7 @@ PRIVATE>
: convert-lambda ( s-exp -- quot )
split-lambda dup "&rest" swap member? [ rest-lambda-vars ] [ dup length ] if
[ localize-lambda <lambda> ] dip
- [ , cut [ dup length firstn ] dip dup empty? [ drop ] when , with-locals ] bake ;
+ [ , cut [ dup length firstn ] dip dup empty? [ drop ] when , ] bake ;
: convert-quoted ( s-exp -- quot )
second [ , ] bake ;
From 6cd0c315c68fbe1a1f2459c0065c218bb19f4399 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 9 May 2008 20:19:13 -0500
Subject: [PATCH 40/41] Align generation sizes on deck boundaries
---
vm/data_gc.c | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/vm/data_gc.c b/vm/data_gc.c
index 9a39642cde..6e32e14991 100755
--- a/vm/data_gc.c
+++ b/vm/data_gc.c
@@ -38,9 +38,9 @@ F_DATA_HEAP *alloc_data_heap(CELL gens,
{
GC_PRINT(ALLOC_DATA_HEAP,gens,young_size,aging_size,tenured_size);
- young_size = align_page(young_size);
- aging_size = align_page(aging_size);
- tenured_size = align_page(tenured_size);
+ young_size = align(young_size,DECK_SIZE);
+ aging_size = align(aging_size,DECK_SIZE);
+ tenured_size = align(tenured_size,DECK_SIZE);
F_DATA_HEAP *data_heap = safe_malloc(sizeof(F_DATA_HEAP));
data_heap->young_size = young_size;
From b6245ddc740fd31bebf5a7dc1c14681c90bcf85a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 9 May 2008 20:30:21 -0500
Subject: [PATCH 41/41] Fix load error in lisp
---
extra/lisp/lisp-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor
index 101af3fa5b..ec376569f0 100644
--- a/extra/lisp/lisp-tests.factor
+++ b/extra/lisp/lisp-tests.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
-USING: lisp lisp.parser tools.test ;
+USING: lisp lisp.parser tools.test sequences math kernel ;
IN: lisp.test