From b77d6601415033ec95a2b01330ed7fab8126635f Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 17 Apr 2008 02:37:03 -0400 Subject: [PATCH 01/51] 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 Date: Thu, 17 Apr 2008 12:37:31 -0400 Subject: [PATCH 02/51] 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 Date: Sun, 20 Apr 2008 01:41:16 -0400 Subject: [PATCH 03/51] 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 Date: Mon, 21 Apr 2008 20:25:29 -0400 Subject: [PATCH 04/51] 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 Date: Mon, 21 Apr 2008 20:25:55 -0400 Subject: [PATCH 05/51] 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: 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 ]] 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" 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 Date: Wed, 23 Apr 2008 09:01:33 -0400 Subject: [PATCH 06/51] 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" equal? ] [ convert-if ] } + { { [ dup "if" equal? ] [ drop convert-if ] } [ drop convert-general-form ] } cond ; From 1069db6d053095278c7c9cf1b855b4784c3c788d Mon Sep 17 00:00:00 2001 From: James Cash Date: Wed, 23 Apr 2008 09:01:54 -0400 Subject: [PATCH 07/51] 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 Date: Thu, 24 Apr 2008 16:35:42 -0400 Subject: [PATCH 08/51] 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: lisp-symbol +C: 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 ]] -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 ]] +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 ; - + +> 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 ; + : convert-list-form ( lisp-form -- quot ) dup first - { { [ dup "if" equal? ] [ drop convert-if ] } + { { [ dup "if" equal? ] [ drop convert-if ] } + { [ dup "begin" equal? ] [ drop convert-begin ] } + { [ dup "cond" equal? ] [ drop convert-cond ] } + { [ dup "lambda" equal? ] [ drop convert-lambda ] } [ drop convert-general-form ] } cond ; From df4023b6a76f695e91d6c50dcc7fefff1c6c9b38 Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 24 Apr 2008 22:50:23 -0400 Subject: [PATCH 09/51] 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 ; : convert-list-form ( lisp-form -- quot ) -dup first - { { [ dup "if" equal? ] [ drop convert-if ] } - { [ dup "begin" equal? ] [ drop convert-begin ] } - { [ dup "cond" equal? ] [ drop convert-cond ] } - { [ dup "lambda" 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 Date: Sat, 26 Apr 2008 15:55:39 -0400 Subject: [PATCH 10/51] 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 + +TUPLE: s-exp body ; +C: 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 ]] +string = dquote ("\" . | !(dquote) . )* dquote => [[ second >string ]] +atom = number + | identifier + | string +list-item = _ (atom|s-expression) _ => [[ second ]] +s-expression = LPAREN (list-item)* RPAREN => [[ second ]] +;EBNF From 1ad1f5ceba4b828c6fdf8d1e49a5a85ac2a4019d Mon Sep 17 00:00:00 2001 From: James Cash Date: Sat, 26 Apr 2008 17:17:34 -0400 Subject: [PATCH 11/51] Switching back from 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 -TUPLE: s-exp body ; -C: 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-expression = LPAREN (list-item)* RPAREN => [[ second ]] ;EBNF From 0c10c13e4d315f70ca72cce99ca7d3ff8e0b6b22 Mon Sep 17 00:00:00 2001 From: James Cash Date: Sat, 26 Apr 2008 17:20:12 -0400 Subject: [PATCH 12/51] 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 - -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 ]] -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 ; -: 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 ; -: 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 Date: Sun, 27 Apr 2008 03:03:49 -0400 Subject: [PATCH 13/51] 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 ; > swap member? [ name>> make-local ] [ ] if ] - [ dup vector? [ localize-body ] [ nip ] if ] if ] with map ; inline + [ dup s-exp? [ body>> localize-body ] [ 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 ; : 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 +TUPLE: s-exp body ; +C: 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 ]] +;EBNF \ No newline at end of file From 5d689e732d7201a601df060a5e8fb3a902d4ea4e Mon Sep 17 00:00:00 2001 From: James Cash Date: Sun, 27 Apr 2008 23:12:18 -0400 Subject: [PATCH 14/51] 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 Date: Sun, 27 Apr 2008 23:12:52 -0400 Subject: [PATCH 15/51] 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 Date: Sun, 27 Apr 2008 23:13:42 -0400 Subject: [PATCH 16/51] 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 Date: Tue, 29 Apr 2008 23:10:47 -0400 Subject: [PATCH 17/51] 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 Date: Wed, 30 Apr 2008 16:59:50 -0400 Subject: [PATCH 18/51] 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 ; first3 -rot nip [ body>> ] bi@ reverse [ name>> ] map dup make-locals dup push-locals [ swap localize-body convert-body ] dipd pop-locals swap ; +: 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 Date: Wed, 30 Apr 2008 17:00:20 -0400 Subject: [PATCH 19/51] 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 ]] -string = dquote ("\" . | !(dquote) . )* dquote => [[ second >string ]] +identifier = initials (subsequents)* => [[ first2 concat append ]] +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 ]] +list-item = _ (atom|s-expression) _ => [[ second ]] +s-expression = LPAREN (list-item)* RPAREN => [[ second ]] ;EBNF \ No newline at end of file From 3e8e976beec14b728570a08623a3bf7097ce0efc Mon Sep 17 00:00:00 2001 From: James Cash Date: Fri, 2 May 2008 03:11:10 -0400 Subject: [PATCH 20/51] 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 Date: Mon, 5 May 2008 12:48:58 -0400 Subject: [PATCH 21/51] 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 Date: Mon, 5 May 2008 12:49:16 -0400 Subject: [PATCH 22/51] 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 ; > swap member? [ name>> make-local ] [ ] if ] - [ dup s-exp? [ body>> localize-body ] [ nip ] if ] if ] with map ; -PRIVATE> + [ dup s-exp? [ body>> localize-body ] [ nip ] if ] if + ] with map ; + +: localize-lambda ( body vars -- newbody newvars ) + dup make-locals dup push-locals [ swap localize-body 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 ; + split-lambda dup "&rest" swap member? [ rest-lambda-vars ] [ dup length ] if + [ localize-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 a233349c1f95be8d8079d37fbca71b1e9ac6278b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 9 May 2008 00:09:12 -0500 Subject: [PATCH 23/51] 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) + cards_offset) #define CARD_TO_ADDR(c) (CELL*)(((CELL)(c) - cards_offset)< Date: Fri, 9 May 2008 16:47:13 +1000 Subject: [PATCH 24/51] 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 [ [ 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 0cd8e61f24ed5d074682961aa5c098a40e75aec4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 9 May 2008 16:38:27 -0500 Subject: [PATCH 25/51] 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 ; - -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" + stream-readln +] unit-test From 30c7f560c115ca2554f47b0fbbb24e69badde282 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 9 May 2008 16:46:24 -0500 Subject: [PATCH 26/51] 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 Date: Fri, 9 May 2008 17:11:10 -0500 Subject: [PATCH 27/51] 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 Date: Fri, 9 May 2008 17:11:20 -0500 Subject: [PATCH 28/51] 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 Date: Fri, 9 May 2008 17:11:30 -0500 Subject: [PATCH 29/51] 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 Date: Fri, 9 May 2008 17:11:46 -0500 Subject: [PATCH 30/51] 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 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 Date: Fri, 9 May 2008 17:14:26 -0500 Subject: [PATCH 31/51] 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 Date: Fri, 9 May 2008 17:30:32 -0500 Subject: [PATCH 32/51] 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) + cards_offset) #define CARD_TO_ADDR(c) (CELL*)(((CELL)(c) - cards_offset)<> 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 Date: Fri, 9 May 2008 18:24:41 -0500 Subject: [PATCH 33/51] 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 Date: Fri, 9 May 2008 18:48:48 -0500 Subject: [PATCH 34/51] 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< Date: Fri, 9 May 2008 18:50:31 -0500 Subject: [PATCH 35/51] 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 Date: Fri, 9 May 2008 20:18:59 -0500 Subject: [PATCH 36/51] 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 ] 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 Date: Fri, 9 May 2008 20:19:13 -0500 Subject: [PATCH 37/51] 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 Date: Fri, 9 May 2008 20:30:21 -0500 Subject: [PATCH 38/51] 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 From 50732a297b9919eb92bf2c4c3a48cd20a5dfa052 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 9 May 2008 20:30:49 -0500 Subject: [PATCH 39/51] builder.report: Put a maximum size on the boot-log in the report --- extra/builder/report/report.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/builder/report/report.factor b/extra/builder/report/report.factor index 101d259f7c..2ac8482a76 100644 --- a/extra/builder/report/report.factor +++ b/extra/builder/report/report.factor @@ -15,8 +15,8 @@ IN: builder.report "Build directory: " write build-dir print "git id: " write "git-id" eval-file print nl - status-vm get f = [ "compile-log" cat "vm compile error" throw ] when - status-boot get f = [ "boot-log" cat "Boot error" throw ] when + status-vm get f = [ "compile-log" cat "vm compile error" throw ] when + status-boot get f = [ "boot-log" 100 cat-n "Boot error" throw ] when status-test get f = [ "test-log" 100 cat-n "Test error" throw ] when "Boot time: " write "boot-time" eval-file milli-seconds>time print From 5337366643fab269ae264b390c2dae96efdbc2c9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 9 May 2008 21:11:27 -0500 Subject: [PATCH 40/51] fix compiler errors in tar, can untar the linux kernel now --- extra/tar/tar.factor | 190 +++++++++++++++++++------------------------ 1 file changed, 83 insertions(+), 107 deletions(-) diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index b5d01b6ed2..644cf9aa72 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -1,99 +1,92 @@ USING: combinators io io.files io.streams.string kernel math math.parser continuations namespaces pack prettyprint sequences -strings system hexdump io.encodings.binary inspector accessors ; +strings system hexdump io.encodings.binary inspector accessors +io.backend symbols byte-arrays ; IN: tar -: zero-checksum 256 ; +: zero-checksum 256 ; inline +: block-size 512 ; inline TUPLE: tar-header name mode uid gid size mtime checksum typeflag linkname magic version uname gname devmajor devminor prefix ; +ERROR: checksum-error ; -: ( -- obj ) tar-header new ; +SYMBOLS: base-dir filename ; -: tar-trim ( seq -- newseq ) - [ "\0 " member? ] trim ; +: tar-trim ( seq -- newseq ) [ "\0 " member? ] trim ; : read-tar-header ( -- obj ) - - 100 read-c-string* over set-tar-header-name - 8 read-c-string* tar-trim oct> over set-tar-header-mode - 8 read-c-string* tar-trim oct> over set-tar-header-uid - 8 read-c-string* tar-trim oct> over set-tar-header-gid - 12 read-c-string* tar-trim oct> over set-tar-header-size - 12 read-c-string* tar-trim oct> over set-tar-header-mtime - 8 read-c-string* tar-trim oct> over set-tar-header-checksum - read1 over set-tar-header-typeflag - 100 read-c-string* over set-tar-header-linkname - 6 read over set-tar-header-magic - 2 read over set-tar-header-version - 32 read-c-string* over set-tar-header-uname - 32 read-c-string* over set-tar-header-gname - 8 read tar-trim oct> over set-tar-header-devmajor - 8 read tar-trim oct> over set-tar-header-devminor - 155 read-c-string* over set-tar-header-prefix ; + \ tar-header new + 100 read-c-string* >>name + 8 read-c-string* tar-trim oct> >>mode + 8 read-c-string* tar-trim oct> >>uid + 8 read-c-string* tar-trim oct> >>gid + 12 read-c-string* tar-trim oct> >>size + 12 read-c-string* tar-trim oct> >>mtime + 8 read-c-string* tar-trim oct> >>checksum + read1 >>typeflag + 100 read-c-string* >>linkname + 6 read >>magic + 2 read >>version + 32 read-c-string* >>uname + 32 read-c-string* >>gname + 8 read tar-trim oct> >>devmajor + 8 read tar-trim oct> >>devminor + 155 read-c-string* >>prefix ; : header-checksum ( seq -- x ) 148 cut-slice 8 tail-slice [ sum ] bi@ + 256 + ; -TUPLE: checksum-error ; -TUPLE: malformed-block-error ; - -SYMBOL: base-dir -SYMBOL: out-stream -SYMBOL: filename - -: (read-data-blocks) ( tar-header -- ) - 512 read [ - over tar-header-size dup 512 <= [ - head-slice - >string write - drop +: read-data-blocks ( tar-header -- ) + dup size>> 0 > [ + block-size read [ + over size>> dup block-size <= [ + head-slice >byte-array write drop + ] [ + drop write + [ block-size - ] change-size + read-data-blocks + ] if ] [ drop - >string write - dup tar-header-size 512 - over set-tar-header-size - (read-data-blocks) - ] if + ] if* ] [ drop - ] if* ; - -: read-data-blocks ( tar-header out -- ) - [ (read-data-blocks) ] with-output-stream* ; + ] if ; : parse-tar-header ( seq -- obj ) [ header-checksum ] keep over zero-checksum = [ 2drop \ tar-header new - 0 over set-tar-header-size - 0 over set-tar-header-checksum + 0 >>size + 0 >>checksum ] [ [ read-tar-header ] with-string-reader - [ tar-header-checksum = [ - \ checksum-error new throw - ] unless - ] keep + [ checksum>> = [ checksum-error ] unless ] keep ] if ; ERROR: unknown-typeflag ch ; M: unknown-typeflag summary ( obj -- str ) - ch>> 1string - "Unknown typeflag: " prepend ; + ch>> 1string "Unknown typeflag: " prepend ; -: tar-append-path ( path -- newpath ) +: tar-prepend-path ( path -- newpath ) base-dir get prepend-path ; +: read/write-blocks ( tar-header path -- ) + binary [ read-data-blocks ] with-file-writer ; + ! Normal file -: typeflag-0 - name>> tar-append-path binary - [ read-data-blocks ] keep dispose ; +: typeflag-0 ( header -- ) + dup name>> tar-prepend-path read/write-blocks ; ! Hard link : typeflag-1 ( header -- ) unknown-typeflag ; ! Symlink -: typeflag-2 ( header -- ) unknown-typeflag ; +: typeflag-2 ( header -- ) + [ name>> ] [ linkname>> ] bi + [ make-link ] 2curry ignore-errors ; ! character special : typeflag-3 ( header -- ) unknown-typeflag ; @@ -103,7 +96,7 @@ M: unknown-typeflag summary ( obj -- str ) ! Directory : typeflag-5 ( header -- ) - tar-header-name tar-append-path make-directories ; + name>> tar-prepend-path make-directories ; ! FIFO : typeflag-6 ( header -- ) unknown-typeflag ; @@ -118,7 +111,7 @@ M: unknown-typeflag summary ( obj -- str ) : typeflag-9 ( header -- ) unknown-typeflag ; ! Global POSIX header -: typeflag-g ( header -- ) unknown-typeflag ; +: typeflag-g ( header -- ) typeflag-0 ; ! Extended POSIX header : typeflag-x ( header -- ) unknown-typeflag ; @@ -140,10 +133,10 @@ M: unknown-typeflag summary ( obj -- str ) ! Long file name : typeflag-L ( header -- ) - [ read-data-blocks ] keep - >string [ zero? ] right-trim filename set - global [ "long filename: " write filename get . flush ] bind - filename get tar-append-path make-directories ; + drop ; + ! [ read-data-blocks ] keep + ! >string [ zero? ] right-trim filename set + ! filename get tar-prepend-path make-directories ; ! Multi volume continuation entry : typeflag-M ( header -- ) unknown-typeflag ; @@ -161,56 +154,39 @@ M: unknown-typeflag summary ( obj -- str ) : typeflag-X ( header -- ) unknown-typeflag ; : (parse-tar) ( -- ) - 512 read - global [ dup hexdump. flush ] bind - [ + block-size read dup length 512 = [ parse-tar-header - ! global [ dup tar-header-name [ print flush ] when* ] bind - dup tar-header-typeflag + dup typeflag>> { { 0 [ typeflag-0 ] } { CHAR: 0 [ typeflag-0 ] } - { CHAR: 1 [ typeflag-1 ] } + ! { CHAR: 1 [ typeflag-1 ] } { CHAR: 2 [ typeflag-2 ] } - { CHAR: 3 [ typeflag-3 ] } - { CHAR: 4 [ typeflag-4 ] } + ! { CHAR: 3 [ typeflag-3 ] } + ! { CHAR: 4 [ typeflag-4 ] } { CHAR: 5 [ typeflag-5 ] } - { CHAR: 6 [ typeflag-6 ] } - { CHAR: 7 [ typeflag-7 ] } + ! { CHAR: 6 [ typeflag-6 ] } + ! { CHAR: 7 [ typeflag-7 ] } { CHAR: g [ typeflag-g ] } - { CHAR: x [ typeflag-x ] } - { CHAR: A [ typeflag-A ] } - { CHAR: D [ typeflag-D ] } - { CHAR: E [ typeflag-E ] } - { CHAR: I [ typeflag-I ] } - { CHAR: K [ typeflag-K ] } - { CHAR: L [ typeflag-L ] } - { CHAR: M [ typeflag-M ] } - { CHAR: N [ typeflag-N ] } - { CHAR: S [ typeflag-S ] } - { CHAR: V [ typeflag-V ] } - { CHAR: X [ typeflag-X ] } - [ unknown-typeflag ] - } case - ! dup tar-header-size zero? [ - ! out-stream get [ dispose ] when - ! out-stream off - ! drop - ! ] [ - ! dup tar-header-name - ! dup parent-dir base-dir prepend-path - ! global [ dup [ . flush ] when* ] bind - ! make-directories - ! out-stream set - ! read-tar-blocks - ! ] if - (parse-tar) - ] when* ; + ! { CHAR: x [ typeflag-x ] } + ! { CHAR: A [ typeflag-A ] } + ! { CHAR: D [ typeflag-D ] } + ! { CHAR: E [ typeflag-E ] } + ! { CHAR: I [ typeflag-I ] } + ! { CHAR: K [ typeflag-K ] } + ! { CHAR: L [ typeflag-L ] } + ! { CHAR: M [ typeflag-M ] } + ! { CHAR: N [ typeflag-N ] } + ! { CHAR: S [ typeflag-S ] } + ! { CHAR: V [ typeflag-V ] } + ! { CHAR: X [ typeflag-X ] } + { f [ drop ] } + } case (parse-tar) + ] [ + drop + ] if ; -: parse-tar ( path -- obj ) - binary [ - "resource:tar-test" base-dir set - global [ nl nl nl "Starting to parse .tar..." print flush ] bind - global [ "Expanding to: " write base-dir get . flush ] bind - (parse-tar) - ] with-file-writer ; +: parse-tar ( path -- ) + normalize-path dup parent-directory base-dir [ + binary [ (parse-tar) ] with-file-reader + ] with-variable ; From 709e35a392a9214888e448f419efc4f34e00fe28 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 10 May 2008 05:40:00 -0500 Subject: [PATCH 41/51] Add the 'unix-system-call' macro --- extra/unix/system-call/system-call.factor | 15 +++++++++++++++ 1 file changed, 15 insertions(+) create mode 100644 extra/unix/system-call/system-call.factor diff --git a/extra/unix/system-call/system-call.factor b/extra/unix/system-call/system-call.factor new file mode 100644 index 0000000000..5a77693ed7 --- /dev/null +++ b/extra/unix/system-call/system-call.factor @@ -0,0 +1,15 @@ + +USING: kernel continuations sequences math accessors inference macros + fry arrays.lib unix ; + +IN: unix.system-call + +ERROR: unix-system-call-error word args message ; + +MACRO: unix-system-call ( quot -- ) + [ ] [ infer in>> ] [ first ] tri + '[ + [ @ dup 0 < [ dup throw ] [ ] if ] + [ drop , narray , swap err_no strerror unix-system-call-error ] + recover + ] ; From 8e341475fe4f562919e73bee6e5f360a86409c5d Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 10 May 2008 05:41:00 -0500 Subject: [PATCH 42/51] unix: Convert a couple of words to the 'unix-system-call' macro --- extra/unix/unix.factor | 16 ++++------------ 1 file changed, 4 insertions(+), 12 deletions(-) diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index fcbd96177b..ad8b5711b8 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax kernel libc structs - math namespaces system combinators vocabs.loader unix.ffi unix.types - qualified ; + math namespaces system combinators vocabs.loader qualified + unix.ffi unix.types unix.system-call ; QUALIFIED: unix.ffi @@ -80,17 +80,9 @@ FUNCTION: uint ntohl ( uint n ) ; FUNCTION: ushort ntohs ( ushort n ) ; FUNCTION: char* strerror ( int errno ) ; -ERROR: open-error path flags prot message ; +: open ( path flags prot -- int ) [ unix.ffi:open ] unix-system-call ; -: open ( path flags prot -- int ) - 3dup unix.ffi:open - dup 0 >= [ >r 3drop r> ] [ drop err_no strerror open-error ] if ; - -ERROR: utime-error path message ; - -: utime ( path buf -- ) - dupd unix.ffi:utime - 0 = [ drop ] [ err_no strerror utime-error ] if ; +: utime ( path buf -- ) [ unix.ffi:utime ] unix-system-call drop ; FUNCTION: int pclose ( void* file ) ; FUNCTION: int pipe ( int* filedes ) ; From 6da3e88de5b8c01135c23b4ba418296829207e02 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 10 May 2008 06:12:54 -0500 Subject: [PATCH 43/51] Move error words from unix to unix.ffi --- extra/unix/ffi/ffi.factor | 5 ++++- extra/unix/unix.factor | 4 ++-- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/extra/unix/ffi/ffi.factor b/extra/unix/ffi/ffi.factor index ec3daab880..e39d95dfa3 100644 --- a/extra/unix/ffi/ffi.factor +++ b/extra/unix/ffi/ffi.factor @@ -9,4 +9,7 @@ C-STRUCT: utimbuf { "time_t" "actime" } { "time_t" "modtime" } ; -FUNCTION: int utime ( char* path, utimebuf* buf ) ; \ No newline at end of file +FUNCTION: int utime ( char* path, utimebuf* buf ) ; + +FUNCTION: int err_no ( ) ; +FUNCTION: char* strerror ( int errno ) ; \ No newline at end of file diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index ad8b5711b8..96c5c7bf66 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -29,7 +29,7 @@ TYPEDEF: ulong size_t ! ! ! Unix functions LIBRARY: factor -FUNCTION: int err_no ( ) ; +! FUNCTION: int err_no ( ) ; FUNCTION: void clear_err_no ( ) ; LIBRARY: libc @@ -78,7 +78,7 @@ FUNCTION: void* mmap ( void* addr, size_t len, int prot, int flags, int fd, off_ FUNCTION: int munmap ( void* addr, size_t len ) ; FUNCTION: uint ntohl ( uint n ) ; FUNCTION: ushort ntohs ( ushort n ) ; -FUNCTION: char* strerror ( int errno ) ; +! FUNCTION: char* strerror ( int errno ) ; : open ( path flags prot -- int ) [ unix.ffi:open ] unix-system-call ; From 4aacf9b3e9dc423e198e929f1b60168e3d257281 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 10 May 2008 06:13:44 -0500 Subject: [PATCH 44/51] Update USING: --- extra/io/unix/backend/backend.factor | 2 +- extra/io/unix/sockets/sockets.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 08ff526f14..902af8fe0d 100644 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien generic assocs kernel kernel.private math -io.nonblocking sequences strings structs sbufs threads unix +io.nonblocking sequences strings structs sbufs threads unix.ffi unix vectors io.buffers io.backend io.encodings math.parser continuations system libc qualified namespaces io.timeouts io.encodings.utf8 accessors ; diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index b60cb5760e..71edbc5500 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -5,7 +5,7 @@ namespaces threads sequences byte-arrays io.nonblocking io.binary io.unix.backend io.streams.duplex io.sockets.impl io.backend io.files io.files.private io.encodings.utf8 math.parser continuations libc combinators system accessors -qualified unix ; +qualified unix.ffi unix ; EXCLUDE: io => read write close ; EXCLUDE: io.sockets => accept ; From 0c1801d213c30db6ab7a6a71c95e87acbfcf036a Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 10 May 2008 06:14:08 -0500 Subject: [PATCH 45/51] unix.system-call: Fix circularity --- extra/unix/system-call/system-call.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/unix/system-call/system-call.factor b/extra/unix/system-call/system-call.factor index 5a77693ed7..f1a6f8811e 100644 --- a/extra/unix/system-call/system-call.factor +++ b/extra/unix/system-call/system-call.factor @@ -1,6 +1,6 @@ USING: kernel continuations sequences math accessors inference macros - fry arrays.lib unix ; + fry arrays.lib unix.ffi ; IN: unix.system-call From d1775f9bfa02d81aaf4f59d2b0c64a46ff873584 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 10 May 2008 06:36:43 -0500 Subject: [PATCH 46/51] io.unix.kqueue: Fix using --- extra/io/unix/kqueue/kqueue.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) mode change 100644 => 100755 extra/io/unix/kqueue/kqueue.factor diff --git a/extra/io/unix/kqueue/kqueue.factor b/extra/io/unix/kqueue/kqueue.factor old mode 100644 new mode 100755 index 8e8fb0ec74..ec82a426d3 --- a/extra/io/unix/kqueue/kqueue.factor +++ b/extra/io/unix/kqueue/kqueue.factor @@ -3,7 +3,7 @@ USING: alien.c-types kernel math math.bitfields namespaces locals accessors combinators threads vectors hashtables sequences assocs continuations sets -unix unix.time unix.kqueue unix.process +unix.ffi unix unix.time unix.kqueue unix.process io.nonblocking io.unix.backend io.launcher io.unix.launcher io.monitors ; IN: io.unix.kqueue From a9bc2309ea0ffaff763b7ede8e9ebca90d319452 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 10 May 2008 09:10:16 -0500 Subject: [PATCH 47/51] unix: Minor cleanups --- extra/unix/system-call/system-call.factor | 12 ++++++------ extra/unix/unix.factor | 2 -- 2 files changed, 6 insertions(+), 8 deletions(-) diff --git a/extra/unix/system-call/system-call.factor b/extra/unix/system-call/system-call.factor index f1a6f8811e..bfcb9ae6ea 100644 --- a/extra/unix/system-call/system-call.factor +++ b/extra/unix/system-call/system-call.factor @@ -7,9 +7,9 @@ IN: unix.system-call ERROR: unix-system-call-error word args message ; MACRO: unix-system-call ( quot -- ) - [ ] [ infer in>> ] [ first ] tri - '[ - [ @ dup 0 < [ dup throw ] [ ] if ] - [ drop , narray , swap err_no strerror unix-system-call-error ] - recover - ] ; + [ ] [ infer in>> ] [ first ] tri + '[ + [ @ dup 0 < [ dup throw ] [ ] if ] + [ drop , narray , swap err_no strerror unix-system-call-error ] + recover + ] ; diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index 96c5c7bf66..e00a2e068a 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -29,7 +29,6 @@ TYPEDEF: ulong size_t ! ! ! Unix functions LIBRARY: factor -! FUNCTION: int err_no ( ) ; FUNCTION: void clear_err_no ( ) ; LIBRARY: libc @@ -78,7 +77,6 @@ FUNCTION: void* mmap ( void* addr, size_t len, int prot, int flags, int fd, off_ FUNCTION: int munmap ( void* addr, size_t len ) ; FUNCTION: uint ntohl ( uint n ) ; FUNCTION: ushort ntohs ( ushort n ) ; -! FUNCTION: char* strerror ( int errno ) ; : open ( path flags prot -- int ) [ unix.ffi:open ] unix-system-call ; From ef1f7d45affe961735e53322555fffb35b350f11 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 10 May 2008 12:21:38 -0500 Subject: [PATCH 48/51] add more bindings to unix/ --- extra/unix/stat/macosx/macosx.factor | 4 ---- extra/unix/unix.factor | 22 ++++++++++++++++++++++ 2 files changed, 22 insertions(+), 4 deletions(-) diff --git a/extra/unix/stat/macosx/macosx.factor b/extra/unix/stat/macosx/macosx.factor index 3741a22413..1cb3994708 100644 --- a/extra/unix/stat/macosx/macosx.factor +++ b/extra/unix/stat/macosx/macosx.factor @@ -27,7 +27,3 @@ C-STRUCT: stat FUNCTION: int stat ( char* pathname, stat* buf ) ; FUNCTION: int lstat ( char* pathname, stat* buf ) ; - -: stat-st_atim stat-st_atimespec ; -: stat-st_mtim stat-st_mtimespec ; -: stat-st_ctim stat-st_ctimespec ; \ No newline at end of file diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index fcbd96177b..f1450a73ae 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -27,6 +27,25 @@ TYPEDEF: ulong size_t : ESRCH 3 ; inline : EEXIST 17 ; inline +C-STRUCT: group + { "char*" "gr_name" } + { "char*" "gr_passwd" } + { "int" "gr_gid" } + { "char**" "gr_mem" } ; + +C-STRUCT: passwd + { "char*" "pw_name" } + { "char*" "pw_passwd" } + { "uid_t" "pw_uid" } + { "gid_t" "pw_gid" } + { "time_t" "pw_change" } + { "char*" "pw_class" } + { "char*" "pw_gecos" } + { "char*" "pw_dir" } + { "char*" "pw_shell" } + { "time_t" "pw_expire" } + { "int" "pw_fields" } ; + ! ! ! Unix functions LIBRARY: factor FUNCTION: int err_no ( ) ; @@ -64,6 +83,9 @@ FUNCTION: int getdtablesize ; FUNCTION: gid_t getegid ; FUNCTION: uid_t geteuid ; FUNCTION: gid_t getgid ; +FUNCTION: int getgrgid_r ( gid_t gid, group* grp, char* buffer, size_t bufsize, group** result ) ; +FUNCTION: int getgrnam_r ( char* name, group* grp, char* buffer, size_t bufsize, group** result ) ; +FUNCTION: int getpwnam_r ( char* login, passwd* pwd, char* buffer, size_t bufsize, passwd** result ) ; FUNCTION: int getgroups ( int gidsetlen, gid_t* gidset ) ; FUNCTION: int gethostname ( char* name, int len ) ; FUNCTION: uid_t getuid ; From 4f1e5241420bd7bb8ddf8a5799ca701333469b62 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 10 May 2008 12:36:57 -0500 Subject: [PATCH 49/51] oops, add back some "dead code" --- extra/unix/stat/macosx/macosx.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/extra/unix/stat/macosx/macosx.factor b/extra/unix/stat/macosx/macosx.factor index 1cb3994708..552547442a 100644 --- a/extra/unix/stat/macosx/macosx.factor +++ b/extra/unix/stat/macosx/macosx.factor @@ -27,3 +27,7 @@ C-STRUCT: stat FUNCTION: int stat ( char* pathname, stat* buf ) ; FUNCTION: int lstat ( char* pathname, stat* buf ) ; + +: stat-st_atim stat-st_atimespec ; +: stat-st_mtim stat-st_mtimespec ; +: stat-st_ctim stat-st_ctimespec ; From 9da8bed8f937f05bbb1eaaad8f150991ae06dacb Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 10 May 2008 13:06:40 -0500 Subject: [PATCH 50/51] refactor miller-rabin a bit still uses too many locals, but at least they're not symbols --- extra/math/miller-rabin/miller-rabin.factor | 58 ++++++++------------- 1 file changed, 21 insertions(+), 37 deletions(-) diff --git a/extra/math/miller-rabin/miller-rabin.factor b/extra/math/miller-rabin/miller-rabin.factor index c668806fc2..2e83fe5ab0 100755 --- a/extra/math/miller-rabin/miller-rabin.factor +++ b/extra/math/miller-rabin/miller-rabin.factor @@ -3,21 +3,9 @@ math.functions math.ranges namespaces random sequences hashtables sets ; IN: math.miller-rabin -SYMBOL: a -SYMBOL: n -SYMBOL: r -SYMBOL: s -SYMBOL: count -SYMBOL: trials - -: >even ( n -- int ) - dup even? [ 1- ] unless ; foldable - -: >odd ( n -- int ) - dup even? [ 1+ ] when ; foldable - -: next-odd ( m -- n ) - dup even? [ 1+ ] [ 2 + ] if ; +: >even ( n -- int ) dup even? [ 1- ] unless ; foldable +: >odd ( n -- int ) dup even? [ 1+ ] when ; foldable +: next-odd ( m -- n ) dup even? [ 1+ ] [ 2 + ] if ; TUPLE: positive-even-expected n ; @@ -28,34 +16,30 @@ TUPLE: positive-even-expected n ; #! factor an integer into s * 2^r 0 swap (factor-2s) ; -:: (miller-rabin) ( n prime?! -- ? ) - n 1- factor-2s s set r set - trials get [ - n 1- [1,b] random a set - a get s get n ^mod 1 = [ - 0 count set - r get [ - 2^ s get * a get swap n ^mod n - -1 = [ - count [ 1+ ] change - r get + - ] when - ] each - count get zero? [ - f prime?! - trials get + - ] when - ] unless - drop - ] each prime? ; - -TUPLE: miller-rabin-bounds ; +:: (miller-rabin) ( n trials -- ? ) + [let | r [ n 1- factor-2s drop ] + s [ n 1- factor-2s nip ] + prime?! [ t ] + a! [ 0 ] + count! [ 0 ] | + trials [ + n 1- [1,b] random a! + a s n ^mod 1 = [ + 0 count! + r [ + 2^ s * a swap n ^mod n - -1 = + [ count 1+ count! r + ] when + ] each + count zero? [ f prime?! trials + ] when + ] unless drop + ] each prime? ] ; : miller-rabin* ( n numtrials -- ? ) over { { [ dup 1 <= ] [ 3drop f ] } { [ dup 2 = ] [ 3drop t ] } { [ dup even? ] [ 3drop f ] } - [ [ drop trials set t (miller-rabin) ] with-scope ] + [ [ drop (miller-rabin) ] with-scope ] } cond ; : miller-rabin ( n -- ? ) 10 miller-rabin* ; From d33b57506a197cdf1ed59ffa16b20bcc46bc0e80 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 10 May 2008 13:18:13 -0500 Subject: [PATCH 51/51] find-relative-prime didn't handle numbers <= 1 correctly --- extra/math/miller-rabin/miller-rabin.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/extra/math/miller-rabin/miller-rabin.factor b/extra/math/miller-rabin/miller-rabin.factor index 2e83fe5ab0..f1953340db 100755 --- a/extra/math/miller-rabin/miller-rabin.factor +++ b/extra/math/miller-rabin/miller-rabin.factor @@ -50,7 +50,11 @@ TUPLE: positive-even-expected n ; : random-prime ( numbits -- p ) random-bits next-prime ; +ERROR: no-relative-prime n ; + : (find-relative-prime) ( n guess -- p ) + over 1 <= [ over no-relative-prime ] when + dup 1 <= [ drop 3 ] when 2dup gcd nip 1 > [ 2 + (find-relative-prime) ] [ nip ] if ; : find-relative-prime* ( n guess -- p )