From d586d49cb6007a0a2f5dc33181f7321d2115ff5f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 29 Mar 2009 16:28:04 -0500
Subject: [PATCH 01/42] Fix listener-run-files
---
basis/ui/tools/listener/listener.factor | 5 +++--
1 file changed, 3 insertions(+), 2 deletions(-)
diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor
index 91448dfe10..7cb3c70cbc 100644
--- a/basis/ui/tools/listener/listener.factor
+++ b/basis/ui/tools/listener/listener.factor
@@ -263,8 +263,9 @@ M: listener-operation invoke-command ( target command -- )
: listener-run-files ( seq -- )
[
- [ \ listener-run-files ] dip
- '[ _ [ run-file ] each ] call-listener
+ '[ _ [ run-file ] each ]
+ \ listener-run-files
+ call-listener
] unless-empty ;
: com-end ( listener -- )
From 2314af94fe9975bce65d8953a7a404f9bcee1bb3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 29 Mar 2009 16:38:12 -0500
Subject: [PATCH 02/42] Remove redundant flush_icache() call
---
vm/code_block.c | 2 --
1 file changed, 2 deletions(-)
diff --git a/vm/code_block.c b/vm/code_block.c
index a9b5277c84..c6ecb2f431 100644
--- a/vm/code_block.c
+++ b/vm/code_block.c
@@ -195,8 +195,6 @@ void mark_code_block(F_CODE_BLOCK *compiled)
copy_handle(&compiled->literals);
copy_handle(&compiled->relocation);
-
- flush_icache_for(compiled);
}
void mark_stack_frame_step(F_STACK_FRAME *frame)
From a40b4f6dfaf9ae333c669493f7660602ce9d49c5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 29 Mar 2009 19:07:01 -0500
Subject: [PATCH 03/42] Fix docs typo
---
basis/ui/tools/browser/browser-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/ui/tools/browser/browser-docs.factor b/basis/ui/tools/browser/browser-docs.factor
index 03a5218e45..b07e72dbce 100644
--- a/basis/ui/tools/browser/browser-docs.factor
+++ b/basis/ui/tools/browser/browser-docs.factor
@@ -2,7 +2,7 @@ USING: help.markup help.syntax ui.commands ;
IN: ui.tools.browser
ARTICLE: "ui-browser" "UI browser"
-"The browser is used to display Factor code, documentation, and vocabularies. The browser is opened when a word or articlelink presentation is clicked. It can also be opened using words:"
+"The browser is used to display Factor code, documentation, and vocabularies. The browser is opened when a word or article link presentation is clicked. It can also be opened using words:"
{ $subsection com-browse }
{ $subsection browser-window }
{ $command-map browser-gadget "toolbar" }
From 13f553b2846a213466cc1a8ffb09cd76ded00632 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@pool-116-90.res.carleton.edu>
Date: Sun, 29 Mar 2009 20:29:38 -0500
Subject: [PATCH 04/42] Fixing farkup's parsing of [aaa]
---
basis/farkup/farkup-tests.factor | 2 +-
basis/farkup/farkup.factor | 13 +++++++------
2 files changed, 8 insertions(+), 7 deletions(-)
diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor
index 7cae523efb..abee7194a2 100644
--- a/basis/farkup/farkup-tests.factor
+++ b/basis/farkup/farkup-tests.factor
@@ -182,7 +182,7 @@ link-no-follow? off
[ "<table><tr><td>foo|bar</td></tr></table>" ] [ "|foo\\|bar|" convert-farkup ] unit-test
[ "<p></p>" ] [ "\\" convert-farkup ] unit-test
-! [ "<p>[abc]</p>" ] [ "[abc]" convert-farkup ] unit-test
+[ "<p>[abc]</p>" ] [ "[abc]" convert-farkup ] unit-test
: random-markup ( -- string )
10 [
diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor
index 41c6c4aa00..c400457c0b 100644
--- a/basis/farkup/farkup.factor
+++ b/basis/farkup/farkup.factor
@@ -121,7 +121,7 @@ DEFER: (parse-paragraph)
] if
] if ;
-: take-until ( state delimiter -- string/f state' )
+: take-until ( state delimiter -- string state'/f )
V{ } clone (take-until) ;
: count= ( string -- n )
@@ -186,11 +186,12 @@ DEFER: (parse-paragraph)
: parse-code ( state -- state' item )
dup 1 look CHAR: [ =
- [ unclip-slice make-paragraph ] [
- "{" take-until
- [ rest ] dip
- "}]" take-until
- [ code boa ] dip swap
+ [ take-line make-paragraph ] [
+ dup "{" take-until [
+ [ nip rest ] dip
+ "}]" take-until
+ [ code boa ] dip swap
+ ] [ drop take-line make-paragraph ] if*
] if ;
: parse-item ( state -- state' item )
From 82b6e32945f39e87a77a67234764676ce7c8100e Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 29 Mar 2009 21:35:57 -0500
Subject: [PATCH 05/42] fix a few compile errors
---
basis/sorting/human/human.factor | 2 +-
extra/bank/bank.factor | 2 +-
extra/irc/client/client.factor | 2 +-
3 files changed, 3 insertions(+), 3 deletions(-)
diff --git a/basis/sorting/human/human.factor b/basis/sorting/human/human.factor
index 1c7392901b..c07ed8758b 100644
--- a/basis/sorting/human/human.factor
+++ b/basis/sorting/human/human.factor
@@ -11,7 +11,7 @@ IN: sorting.human
: human>=< ( obj1 obj2 -- >=< ) human<=> invert-comparison ; inline
-: human-compare ( obj1 obj2 quot -- <=> ) bi@ human<=> ;
+: human-compare ( obj1 obj2 quot -- <=> ) bi@ human<=> ; inline
: human-sort ( seq -- seq' ) [ human<=> ] sort ;
diff --git a/extra/bank/bank.factor b/extra/bank/bank.factor
index 0f8b5581df..2584335672 100644
--- a/extra/bank/bank.factor
+++ b/extra/bank/bank.factor
@@ -59,7 +59,7 @@ C: <transaction> transaction
[ dup [ over [ swap call ] dip ] dip 1 days time+ ] dip each-day
] [
3drop
- ] if ;
+ ] if ; inline
: process-to-date ( account date -- account )
over interest-last-paid>> 1 days time+
diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor
index c82f2e292c..97fa659209 100755
--- a/extra/irc/client/client.factor
+++ b/extra/irc/client/client.factor
@@ -165,7 +165,7 @@ M: irc-chat to-chat in-messages>> mailbox-put ;
" hostname servername :irc.factor" irc-print ;
: /CONNECT ( server port -- stream )
- irc> connect>> call drop ;
+ irc> connect>> call drop ; inline
: /JOIN ( channel password -- )
"JOIN " irc-write
From 95cda29b4435fbe1f74b651417ae0f9554b3e85c Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 29 Mar 2009 21:39:21 -0500
Subject: [PATCH 06/42] fix compile error
---
extra/bank/bank.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/bank/bank.factor b/extra/bank/bank.factor
index 2584335672..f06bc2fb81 100644
--- a/extra/bank/bank.factor
+++ b/extra/bank/bank.factor
@@ -59,11 +59,11 @@ C: <transaction> transaction
[ dup [ over [ swap call ] dip ] dip 1 days time+ ] dip each-day
] [
3drop
- ] if ; inline
+ ] if ; inline recursive
: process-to-date ( account date -- account )
over interest-last-paid>> 1 days time+
- [ dupd process-day ] spin each-day ;
+ [ dupd process-day ] spin each-day ; inline
: inserting-transactions ( account transactions -- account )
[ [ date>> process-to-date ] keep >>transaction ] each ;
From 5a903d7bcd935efab6134f74e60a845ed13346cb Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 29 Mar 2009 22:46:27 -0500
Subject: [PATCH 07/42] Fix a bug in CONSTANT: -- it wasn't calling reset-word
---
core/syntax/syntax.factor | 2 +-
core/words/alias/alias-tests.factor | 6 ++++++
2 files changed, 7 insertions(+), 1 deletion(-)
create mode 100644 core/words/alias/alias-tests.factor
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index bcf9decdf3..cb5cdfd5ac 100644
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -138,7 +138,7 @@ IN: bootstrap.syntax
] define-core-syntax
"CONSTANT:" [
- CREATE scan-object define-constant
+ CREATE-WORD scan-object define-constant
] define-core-syntax
":" [
diff --git a/core/words/alias/alias-tests.factor b/core/words/alias/alias-tests.factor
new file mode 100644
index 0000000000..0278a4d4b9
--- /dev/null
+++ b/core/words/alias/alias-tests.factor
@@ -0,0 +1,6 @@
+USING: math eval tools.test effects ;
+IN: words.alias.tests
+
+ALIAS: foo +
+[ ] [ "IN: words.alias.tests CONSTANT: foo 5" eval ] unit-test
+[ (( -- value )) ] [ \ foo stack-effect ] unit-test
\ No newline at end of file
From 5ecff284effd254bacd6498dc13cb7997de37d77 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@pool-116-90.res.carleton.edu>
Date: Sun, 29 Mar 2009 22:57:13 -0500
Subject: [PATCH 08/42] Fixing regexp compiler's bounds checks
---
basis/regexp/compiler/compiler.factor | 24 +++++++++++++++---------
1 file changed, 15 insertions(+), 9 deletions(-)
diff --git a/basis/regexp/compiler/compiler.factor b/basis/regexp/compiler/compiler.factor
index 6c7896dcca..5482734865 100644
--- a/basis/regexp/compiler/compiler.factor
+++ b/basis/regexp/compiler/compiler.factor
@@ -84,21 +84,24 @@ C: <box> box
{ } assoc-like [ first integer? ] partition
[ [ literals>cases ] keep ] dip non-literals>dispatch ;
-:: step ( last-match index str quot final? direction -- last-index/f )
+: advance ( index backwards? -- index+/-1 )
+ -1 1 ? + >fixnum ; inline
+
+: check ( index string backwards? -- in-bounds? )
+ [ drop -1 eq? not ] [ length < ] if ; inline
+
+:: step ( last-match index str quot final? backwards? -- last-index/f )
final? index last-match ?
- index str bounds-check? [
- index direction + str
+ index str backwards? check [
+ index backwards? advance str
index str nth-unsafe
quot call
] when ; inline
-: direction ( -- n )
- backwards? get -1 1 ? ;
-
: transitions>quot ( transitions final-state? -- quot )
dup shortest? get and [ 2drop [ drop nip ] ] [
- [ split-literals swap case>quot ] dip direction
- '[ { array-capacity string } declare _ _ _ step ]
+ [ split-literals swap case>quot ] dip backwards? get
+ '[ { fixnum string } declare _ _ _ step ]
] if ;
: word>quot ( word dfa -- quot )
@@ -122,10 +125,13 @@ C: <box> box
: dfa>main-word ( dfa -- word )
states>words [ states>code ] keep start-state>> ;
+: word-template ( quot -- quot' )
+ '[ drop [ f ] 2dip over array-capacity? _ [ 2drop ] if ] ;
+
PRIVATE>
: dfa>word ( dfa -- quot )
- dfa>main-word execution-quot '[ drop [ f ] 2dip @ ]
+ dfa>main-word execution-quot word-template
(( start-index string regexp -- i/f )) define-temp ;
: dfa>shortest-word ( dfa -- word )
From f657c60c4f3c235e193ce8f4931eb0f9a01fc843 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@pool-116-90.res.carleton.edu>
Date: Sun, 29 Mar 2009 22:58:04 -0500
Subject: [PATCH 09/42] Some cleanup in documents.elements
---
basis/documents/elements/elements.factor | 24 ++++++++++++------------
1 file changed, 12 insertions(+), 12 deletions(-)
diff --git a/basis/documents/elements/elements.factor b/basis/documents/elements/elements.factor
index adb498df13..9a8b82acac 100644
--- a/basis/documents/elements/elements.factor
+++ b/basis/documents/elements/elements.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators documents fry kernel math sequences
-unicode.categories accessors ;
+accessors unicode.categories combinators.short-circuit ;
IN: documents.elements
GENERIC: prev-elt ( loc document elt -- newloc )
@@ -20,14 +20,14 @@ SINGLETON: char-elt
<PRIVATE
-: (prev-char) ( loc document quot -- loc )
+: prev ( loc document quot: ( loc document -- loc ) -- loc )
{
{ [ pick { 0 0 } = ] [ 2drop ] }
{ [ pick second zero? ] [ drop [ first 1- ] dip line-end ] }
[ call ]
} cond ; inline
-: (next-char) ( loc document quot -- loc )
+: next ( loc document quot: ( loc document -- loc )
{
{ [ 2over doc-end = ] [ 2drop ] }
{ [ 2over line-end? ] [ 2drop first 1+ 0 2array ] }
@@ -37,10 +37,10 @@ SINGLETON: char-elt
PRIVATE>
M: char-elt prev-elt
- drop [ drop -1 +col ] (prev-char) ;
+ drop [ drop -1 +col ] prev ;
M: char-elt next-elt
- drop [ drop 1 +col ] (next-char) ;
+ drop [ drop 1 +col ] next ;
SINGLETON: one-char-elt
@@ -55,7 +55,7 @@ M: one-char-elt next-elt 2drop ;
[ [ first2 swap ] dip doc-line ] dip call
] dip =col ; inline
-: ((word-elt)) ( n seq -- n seq ? )
+: blank-at? ( n seq -- n seq ? )
2dup ?nth blank? ;
: break-detector ( ? -- quot )
@@ -65,7 +65,7 @@ M: one-char-elt next-elt 2drop ;
break-detector find-last-from drop ?1+ ;
: (next-word) ( col str ? -- col )
- [ break-detector find-from drop ] [ drop length ] 2bi or ;
+ { [ break-detector find-from drop ] [ drop length ] } 2|| ;
PRIVATE>
@@ -83,13 +83,13 @@ SINGLETON: word-elt
M: word-elt prev-elt
drop
- [ [ [ 1- ] dip ((word-elt)) (prev-word) ] (word-elt) ]
- (prev-char) ;
+ [ [ [ 1- ] dip blank-at? (prev-word) ] (word-elt) ]
+ prev ;
M: word-elt next-elt
drop
- [ [ ((word-elt)) (next-word) ] (word-elt) ]
- (next-char) ;
+ [ [ blank-at? (next-word) ] (word-elt) ]
+ next ;
SINGLETON: one-line-elt
@@ -118,4 +118,4 @@ SINGLETON: doc-elt
M: doc-elt prev-elt 3drop { 0 0 } ;
-M: doc-elt next-elt drop nip doc-end ;
\ No newline at end of file
+M: doc-elt next-elt drop nip doc-end ;
From bd91ac56cebf4166cda3ba66728f4e697bfef9f4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 29 Mar 2009 23:13:30 -0500
Subject: [PATCH 10/42] Fix model docs
---
basis/models/models-docs.factor | 11 ++++++-----
1 file changed, 6 insertions(+), 5 deletions(-)
diff --git a/basis/models/models-docs.factor b/basis/models/models-docs.factor
index 82dd035467..2b90bdb0d5 100644
--- a/basis/models/models-docs.factor
+++ b/basis/models/models-docs.factor
@@ -5,12 +5,13 @@ IN: models
HELP: model
{ $class-description "A mutable cell holding a single value. When the value is changed, a sequence of connected objects are notified. Models have the following slots:"
{ $list
- { { $snippet "value" } " - the value of the model. Use " { $link set-model } " to change the value." }
- { { $snippet "connections" } " - a sequence of objects implementing the " { $link model-changed } " generic word, to be notified when the model's value changes." }
- { { $snippet "dependencies" } " - a sequence of models which should have this model added to their sequence of connections when activated." }
- { { $snippet "ref" } " - a reference count tracking the number of models which depend on this one." }
+ { { $slot "value" } " - the value of the model. Use " { $link set-model } " to change the value." }
+ { { $slot "connections" } " - a sequence of objects implementing the " { $link model-changed } " generic word, to be notified when the model's value changes." }
+ { { $slot "dependencies" } " - a sequence of models which should have this model added to their sequence of connections when activated." }
+ { { $slot "ref" } " - a reference count tracking the number of models which depend on this one." }
+ { { $slot "locked?" } " - a slot set by " { $link with-locked-model } " to ensure that the model doesn't get changed recursively" }
}
-"Other classes may delegate to " { $link model } "."
+"Other classes may inherit from " { $link model } "."
} ;
HELP: <model>
From c1297ec177589928d9de688d4130be9e721da0d8 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Mon, 30 Mar 2009 00:18:02 -0500
Subject: [PATCH 11/42] add unit tests for quoting
---
basis/quoting/quoting-tests.factor | 11 +++++++++++
1 file changed, 11 insertions(+)
create mode 100644 basis/quoting/quoting-tests.factor
diff --git a/basis/quoting/quoting-tests.factor b/basis/quoting/quoting-tests.factor
new file mode 100644
index 0000000000..f024d9c4a7
--- /dev/null
+++ b/basis/quoting/quoting-tests.factor
@@ -0,0 +1,11 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test quoting ;
+IN: quoting.tests
+
+[ f ] [ "" quoted? ] unit-test
+[ t ] [ "''" quoted? ] unit-test
+[ t ] [ "\"\"" quoted? ] unit-test
+[ t ] [ "\"Circus Maximus\"" quoted? ] unit-test
+[ t ] [ "'Circus Maximus'" quoted? ] unit-test
+[ f ] [ "Circus Maximus" quoted? ] unit-test
From 00c9cde8e2edaf806d31b7ef676e16219f53b06a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 30 Mar 2009 05:31:50 -0500
Subject: [PATCH 12/42] First checkin of extra/smalltalk
---
extra/smalltalk/ast/ast.factor | 18 ++
extra/smalltalk/ast/authors.txt | 1 +
extra/smalltalk/authors.txt | 1 +
extra/smalltalk/compiler/authors.txt | 1 +
.../smalltalk/compiler/compiler-tests.factor | 45 ++++
extra/smalltalk/compiler/compiler.factor | 102 +++++++++
extra/smalltalk/compiler/lexenv/authors.txt | 1 +
extra/smalltalk/compiler/lexenv/lexenv.factor | 14 ++
extra/smalltalk/parser/authors.txt | 1 +
extra/smalltalk/parser/parser-tests.factor | 137 ++++++++++++
extra/smalltalk/parser/parser.factor | 203 ++++++++++++++++++
extra/smalltalk/parser/test.st | 66 ++++++
extra/smalltalk/selectors/authors.txt | 1 +
extra/smalltalk/selectors/selectors.factor | 26 +++
extra/smalltalk/smalltalk.factor | 4 +
15 files changed, 621 insertions(+)
create mode 100644 extra/smalltalk/ast/ast.factor
create mode 100644 extra/smalltalk/ast/authors.txt
create mode 100644 extra/smalltalk/authors.txt
create mode 100644 extra/smalltalk/compiler/authors.txt
create mode 100644 extra/smalltalk/compiler/compiler-tests.factor
create mode 100644 extra/smalltalk/compiler/compiler.factor
create mode 100644 extra/smalltalk/compiler/lexenv/authors.txt
create mode 100644 extra/smalltalk/compiler/lexenv/lexenv.factor
create mode 100644 extra/smalltalk/parser/authors.txt
create mode 100644 extra/smalltalk/parser/parser-tests.factor
create mode 100644 extra/smalltalk/parser/parser.factor
create mode 100644 extra/smalltalk/parser/test.st
create mode 100644 extra/smalltalk/selectors/authors.txt
create mode 100644 extra/smalltalk/selectors/selectors.factor
create mode 100644 extra/smalltalk/smalltalk.factor
diff --git a/extra/smalltalk/ast/ast.factor b/extra/smalltalk/ast/ast.factor
new file mode 100644
index 0000000000..83e6d0ae84
--- /dev/null
+++ b/extra/smalltalk/ast/ast.factor
@@ -0,0 +1,18 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: strings arrays memoize kernel ;
+IN: smalltalk.ast
+
+SINGLETONS: nil self super ;
+
+TUPLE: ast-comment { string string } ;
+TUPLE: ast-block { arguments array } { body array } ;
+TUPLE: ast-message-send receiver { selector string } { arguments array } ;
+TUPLE: ast-name { name string } ;
+TUPLE: ast-return value ;
+TUPLE: ast-assignment { name ast-name } value ;
+TUPLE: ast-local-variables { names array } ;
+TUPLE: ast-method { name string } { body ast-block } ;
+TUPLE: ast-class { name string } { superclass string } { ivars array } { methods array } ;
+TUPLE: symbol { name string } ;
+MEMO: intern ( name -- symbol ) symbol boa ;
\ No newline at end of file
diff --git a/extra/smalltalk/ast/authors.txt b/extra/smalltalk/ast/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/ast/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/authors.txt b/extra/smalltalk/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/authors.txt b/extra/smalltalk/compiler/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/compiler/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/compiler-tests.factor b/extra/smalltalk/compiler/compiler-tests.factor
new file mode 100644
index 0000000000..ee944baf02
--- /dev/null
+++ b/extra/smalltalk/compiler/compiler-tests.factor
@@ -0,0 +1,45 @@
+USING: smalltalk.compiler tools.test prettyprint smalltalk.ast
+stack-checker locals.rewrite.closures kernel accessors
+compiler.units sequences ;
+IN: smalltalk.compiler.tests
+
+[ 2 1 ] [
+ [
+ T{ ast-block f
+ { "a" "b" }
+ {
+ T{ ast-message-send f
+ T{ ast-name f "a" }
+ "+"
+ { T{ ast-name f "b" } }
+ }
+ }
+ } compile-method
+ [ . ] [ rewrite-closures first infer [ in>> ] [ out>> ] bi ] bi
+ ] with-compilation-unit
+] unit-test
+
+[ 3 1 ] [
+ [
+ T{ ast-block f
+ { "a" "b" "c" }
+ {
+ T{ ast-assignment f
+ T{ ast-name f "a" }
+ T{ ast-message-send f
+ T{ ast-name f "a" }
+ "+"
+ { T{ ast-name f "b" } }
+ }
+ }
+ T{ ast-message-send f
+ T{ ast-name f "b" }
+ "blah:"
+ { 123.456 }
+ }
+ T{ ast-return f T{ ast-name f "c" } }
+ }
+ } compile-method
+ [ . ] [ rewrite-closures first infer [ in>> ] [ out>> ] bi ] bi
+ ] with-compilation-unit
+] unit-test
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor
new file mode 100644
index 0000000000..1f3b0f94e5
--- /dev/null
+++ b/extra/smalltalk/compiler/compiler.factor
@@ -0,0 +1,102 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators.short-circuit
+continuations fry kernel namespaces quotations sequences sets
+slots locals.types generalizations smalltalk.ast
+smalltalk.compiler.lexenv smalltalk.selectors ;
+IN: smalltalk.compiler
+
+SYMBOL: return-continuation
+
+GENERIC: need-return-continuation? ( ast -- ? )
+
+M: ast-return need-return-continuation? drop t ;
+
+M: ast-block need-return-continuation? body>> [ need-return-continuation? ] any? ;
+
+M: ast-message-send need-return-continuation?
+ {
+ [ receiver>> need-return-continuation? ]
+ [ arguments>> [ need-return-continuation? ] any? ]
+ } 1&& ;
+
+M: ast-assignment need-return-continuation?
+ value>> need-return-continuation? ;
+
+M: object need-return-continuation? drop f ;
+
+GENERIC: assigned-locals ( ast -- seq )
+
+M: ast-return assigned-locals value>> assigned-locals ;
+
+M: ast-block assigned-locals
+ [ body>> [ assigned-locals ] map concat ] [ arguments>> ] bi diff ;
+
+M: ast-message-send assigned-locals
+ [ receiver>> assigned-locals ]
+ [ arguments>> [ assigned-locals ] map ] bi append ;
+
+M: ast-assignment assigned-locals
+ [ name>> dup ast-name? [ name>> 1array ] [ drop { } ] if ]
+ [ value>> assigned-locals ] bi append ;
+
+M: object assigned-locals drop f ;
+
+GENERIC: compile-ast ( lexenv ast -- quot )
+
+M: object compile-ast nip 1quotation ;
+
+ERROR: unbound-local name ;
+
+M: ast-name compile-ast
+ name>> swap local-readers>> at 1quotation ;
+
+M: ast-message-send compile-ast
+ [ receiver>> compile-ast ]
+ [ arguments>> [ compile-ast ] with map concat ]
+ [ nip selector>> selector>generic ]
+ 2tri [ append ] dip suffix ;
+
+M: ast-return compile-ast
+ value>> compile-ast
+ [ return-continuation get continue-with ] append ;
+
+GENERIC: compile-assignment ( lexenv name -- quot )
+
+M: ast-name compile-assignment
+ name>> swap local-writers>> at 1quotation ;
+
+M: ast-assignment compile-ast
+ [ value>> compile-ast [ dup ] ] [ name>> compile-assignment ] 2bi 3append ;
+
+: block-lexenv ( block -- lexenv )
+ [ arguments>> ] [ body>> [ assigned-locals ] map concat unique ] bi
+ '[
+ dup dup _ key?
+ [ <local-reader> ]
+ [ <local> ]
+ if
+ ] { } map>assoc
+ dup
+ [ nip local-reader? ] assoc-filter
+ [ <local-writer> ] assoc-map
+ <lexenv> ;
+
+M: ast-block compile-ast
+ [
+ block-lexenv
+ [ nip local-readers>> values ]
+ [ lexenv-union ] 2bi
+ ] [ body>> ] bi
+ [ drop [ nil ] ] [
+ unclip-last
+ [ [ compile-ast [ drop ] append ] with map [ ] join ]
+ [ compile-ast ]
+ bi-curry* bi
+ append
+ ] if-empty
+ <lambda> '[ @ ] ;
+
+: compile-method ( block -- quot )
+ [ [ empty-lexenv ] dip compile-ast ] [ arguments>> length ] [ need-return-continuation? ] tri
+ [ '[ [ _ _ ncurry [ return-continuation set ] prepose callcc1 ] with-scope ] ] [ drop ] if ;
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/lexenv/authors.txt b/extra/smalltalk/compiler/lexenv/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/compiler/lexenv/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/lexenv/lexenv.factor b/extra/smalltalk/compiler/lexenv/lexenv.factor
new file mode 100644
index 0000000000..2488a54c5f
--- /dev/null
+++ b/extra/smalltalk/compiler/lexenv/lexenv.factor
@@ -0,0 +1,14 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs kernel accessors ;
+IN: smalltalk.compiler.lexenv
+
+TUPLE: lexenv local-readers local-writers ;
+
+C: <lexenv> lexenv
+
+CONSTANT: empty-lexenv T{ lexenv }
+
+: lexenv-union ( lexenv1 lexenv2 -- lexenv )
+ [ [ local-readers>> ] bi@ assoc-union ]
+ [ [ local-writers>> ] bi@ assoc-union ] 2bi <lexenv> ;
diff --git a/extra/smalltalk/parser/authors.txt b/extra/smalltalk/parser/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/parser/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/parser/parser-tests.factor b/extra/smalltalk/parser/parser-tests.factor
new file mode 100644
index 0000000000..9a6614aa07
--- /dev/null
+++ b/extra/smalltalk/parser/parser-tests.factor
@@ -0,0 +1,137 @@
+IN: smalltalk.parser.tests
+USING: smalltalk.parser smalltalk.ast peg.ebnf tools.test accessors
+io.files io.encodings.ascii kernel ;
+
+EBNF: test-Character
+test = <foreign parse-smalltalk Character>
+;EBNF
+
+[ CHAR: a ] [ "a" test-Character ] unit-test
+
+EBNF: test-Comment
+test = <foreign parse-smalltalk Comment>
+;EBNF
+
+[ T{ ast-comment f "Hello, this is a comment." } ]
+[ "\"Hello, this is a comment.\"" test-Comment ]
+unit-test
+
+[ T{ ast-comment f "Hello, \"this\" is a comment." } ]
+[ "\"Hello, \"\"this\"\" is a comment.\"" test-Comment ]
+unit-test
+
+EBNF: test-Identifier
+test = <foreign parse-smalltalk Identifier>
+;EBNF
+
+[ "OrderedCollection" ] [ "OrderedCollection" test-Identifier ] unit-test
+
+EBNF: test-Literal
+test = <foreign parse-smalltalk Literal>
+;EBNF
+
+[ nil ] [ "nil" test-Literal ] unit-test
+[ 123 ] [ "123" test-Literal ] unit-test
+[ HEX: deadbeef ] [ "16rdeadbeef" test-Literal ] unit-test
+[ -123 ] [ "-123" test-Literal ] unit-test
+[ 1.2 ] [ "1.2" test-Literal ] unit-test
+[ -1.24 ] [ "-1.24" test-Literal ] unit-test
+[ 12.4e7 ] [ "12.4e7" test-Literal ] unit-test
+[ 12.4e-7 ] [ "12.4e-7" test-Literal ] unit-test
+[ -12.4e7 ] [ "-12.4e7" test-Literal ] unit-test
+[ CHAR: x ] [ "$x" test-Literal ] unit-test
+[ "Hello, world" ] [ "'Hello, world'" test-Literal ] unit-test
+[ "Hello, 'funny' world" ] [ "'Hello, ''funny'' world'" test-Literal ] unit-test
+[ T{ symbol f "foo" } ] [ "#foo" test-Literal ] unit-test
+[ T{ symbol f "+" } ] [ "#+" test-Literal ] unit-test
+[ T{ symbol f "at:put:" } ] [ "#at:put:" test-Literal ] unit-test
+[ T{ symbol f "Hello world" } ] [ "#'Hello world'" test-Literal ] unit-test
+[ B{ 1 2 3 4 } ] [ "#[1 2 3 4]" test-Literal ] unit-test
+[ { nil t f } ] [ "#(nil true false)" test-Literal ] unit-test
+[ { nil { t f } } ] [ "#(nil (true false))" test-Literal ] unit-test
+[ T{ ast-block f { } { } } ] [ "[]" test-Literal ] unit-test
+[ T{ ast-block f { "x" } { T{ ast-return f T{ ast-name f "x" } } } } ] [ "[ :x|^x]" test-Literal ] unit-test
+[ T{ ast-block f { } { T{ ast-return f self } } } ] [ "[^self]" test-Literal ] unit-test
+
+EBNF: test-FormalBlockArgumentDeclarationList
+test = <foreign parse-smalltalk FormalBlockArgumentDeclarationList>
+;EBNF
+
+[ V{ "x" "y" "elt" } ] [ ":x :y :elt" test-FormalBlockArgumentDeclarationList ] unit-test
+
+EBNF: test-Operand
+test = <foreign parse-smalltalk Operand>
+;EBNF
+
+[ { 123 15.6 { t f } } ] [ "#(123 15.6 (true false))" test-Operand ] unit-test
+[ T{ ast-name f "x" } ] [ "x" test-Operand ] unit-test
+
+EBNF: test-Expression
+test = <foreign parse-smalltalk Expression>
+;EBNF
+
+[ self ] [ "self" test-Expression ] unit-test
+[ { 123 15.6 { t f } } ] [ "#(123 15.6 (true false))" test-Expression ] unit-test
+[ T{ ast-name f "x" } ] [ "x" test-Expression ] unit-test
+[ T{ ast-message-send f 5 "print" { } } ] [ "5 print" test-Expression ] unit-test
+[ T{ ast-message-send f T{ ast-message-send f 5 "squared" { } } "print" { } } ] [ "5 squared print" test-Expression ] unit-test
+[ T{ ast-message-send f 2 "+" { 2 } } ] [ "2+2" test-Expression ] unit-test
+
+[
+ T{ ast-message-send f
+ T{ ast-message-send f 3 "factorial" { } }
+ "+"
+ { T{ ast-message-send f 4 "factorial" { } } }
+ }
+]
+[ "3 factorial + 4 factorial" test-Expression ] unit-test
+
+[
+ T{ ast-message-send f
+ T{ ast-message-send f
+ T{ ast-message-send f 3 "factorial" { } }
+ "+"
+ { 4 }
+ }
+ "factorial"
+ { }
+ }
+]
+[ "(3 factorial + 4) factorial" test-Expression ] unit-test
+EBNF: test-FinalStatement
+test = <foreign parse-smalltalk FinalStatement>
+;EBNF
+
+[ T{ ast-return f T{ ast-name f "value" } } ] [ "value" test-FinalStatement ] unit-test
+[ T{ ast-return f T{ ast-name f "value" } } ] [ "^value" test-FinalStatement ] unit-test
+[ T{ ast-return f T{ ast-assignment f T{ ast-name f "value" } 5 } } ] [ "value:=5" test-FinalStatement ] unit-test
+
+EBNF: test-LocalVariableDeclarationList
+test = <foreign parse-smalltalk LocalVariableDeclarationList>
+;EBNF
+
+[ T{ ast-local-variables f { "i" "j" } } ] [ " | i j |" test-LocalVariableDeclarationList ] unit-test
+
+
+EBNF: test-KeywordMessageSend
+test = <foreign parse-smalltalk KeywordMessageSend>
+;EBNF
+
+[ T{ ast-message-send f T{ ast-name f "x" } "foo:bar:" { 1 2 } } ]
+[ "x foo:1 bar:2" test-KeywordMessageSend ] unit-test
+
+[
+ T{ ast-message-send
+ f
+ T{ ast-message-send f
+ T{ ast-message-send f 3 "factorial" { } }
+ "+"
+ { T{ ast-message-send f 4 "factorial" { } } }
+ }
+ "between:and:"
+ { 10 100 }
+ }
+]
+[ "3 factorial + 4 factorial between: 10 and: 100" test-KeywordMessageSend ] unit-test
+
+[ ] [ "vocab:smalltalk/parser/test.st" ascii file-contents parse-smalltalk drop ] unit-test
diff --git a/extra/smalltalk/parser/parser.factor b/extra/smalltalk/parser/parser.factor
new file mode 100644
index 0000000000..2822165938
--- /dev/null
+++ b/extra/smalltalk/parser/parser.factor
@@ -0,0 +1,203 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: peg peg.ebnf smalltalk.ast sequences sequences.deep strings
+math.parser kernel arrays byte-arrays math assocs ;
+IN: smalltalk.parser
+
+! Based on http://chronos-st.blogspot.com/2007/12/smalltalk-in-one-page.html
+
+ERROR: bad-number str ;
+
+: check-number ( str -- n )
+ >string dup string>number [ ] [ bad-number ] ?if ;
+
+EBNF: parse-smalltalk
+
+Character = .
+WhitespaceCharacter = (" " | "\t" | "\n" | "\r" )
+DecimalDigit = [0-9]
+Letter = [A-Za-z]
+
+CommentCharacter = [^"] | '""' => [[ CHAR: " ]]
+Comment = '"' (CommentCharacter)*:s '"' => [[ s >string ast-comment boa ]]
+
+OptionalWhiteSpace = (WhitespaceCharacter | Comment)*
+Whitespace = (WhitespaceCharacter | Comment)+
+
+LetterOrDigit = DecimalDigit | Letter
+Identifier = (Letter | "_"):h (LetterOrDigit | "_")*:t => [[ { h t } flatten >string ]]
+Reference = Identifier => [[ ast-name boa ]]
+
+ConstantReference = "nil" => [[ nil ]]
+ | "false" => [[ f ]]
+ | "true" => [[ t ]]
+PseudoVariableReference = "self" => [[ self ]]
+ | "super" => [[ super ]]
+ReservedIdentifier = PseudoVariableReference | ConstantReference
+
+BindableIdentifier = Identifier
+
+UnaryMessageSelector = Identifier
+
+Keyword = Identifier:i ":" => [[ i ":" append ]]
+
+KeywordMessageSelector = Keyword+ => [[ concat ]]
+BinarySelectorChar = "~" | "!" | "@" | "%" | "&" | "*" | "-" | "+"
+ | "=" | "|" | "\" | "<" | ">" | "," | "?" | "/"
+BinaryMessageSelector = BinarySelectorChar+ => [[ concat ]]
+
+OptionalMinus = ("-" => [[ CHAR: - ]])?
+IntegerLiteral = (OptionalMinus:m UnsignedIntegerLiteral:i) => [[ i m [ neg ] when ]]
+UnsignedIntegerLiteral = Radix:r "r" BaseNIntegerLiteral:b => [[ b >string r base> ]]
+ | DecimalIntegerLiteral => [[ check-number ]]
+DecimalIntegerLiteral = DecimalDigit+
+Radix = DecimalIntegerLiteral => [[ check-number ]]
+BaseNIntegerLiteral = LetterOrDigit+
+FloatingPointLiteral = (OptionalMinus
+ DecimalIntegerLiteral
+ ("." => [[ CHAR: . ]] DecimalIntegerLiteral Exponent? | Exponent))
+ => [[ flatten check-number ]]
+Exponent = "e" => [[ CHAR: e ]] (OptionalMinus DecimalIntegerLiteral)?
+
+CharacterLiteral = "$" Character:c => [[ c ]]
+
+StringLiteral = "'" (StringLiteralCharacter | "''" => [[ CHAR: ' ]])*:s "'"
+ => [[ s >string ]]
+StringLiteralCharacter = [^']
+
+SymbolInArrayLiteral = KeywordMessageSelector
+ | UnaryMessageSelector
+ | BinaryMessageSelector
+SymbolLiteral = "#" (SymbolInArrayLiteral | StringLiteral):s => [[ s intern ]]
+
+ArrayLiteral = (ObjectArrayLiteral | ByteArrayLiteral)
+ObjectArrayLiteral = "#" NestedObjectArrayLiteral:elts => [[ elts ]]
+NestedObjectArrayLiteral = "(" OptionalWhiteSpace
+ (LiteralArrayElement:h
+ (Whitespace LiteralArrayElement:e => [[ e ]])*:t
+ => [[ t h prefix ]]
+ )?:elts OptionalWhiteSpace ")" => [[ elts >array ]]
+
+LiteralArrayElement = Literal
+ | NestedObjectArrayLiteral
+ | SymbolInArrayLiteral
+ | ConstantReference
+
+ByteArrayLiteral = "#[" OptionalWhiteSpace
+ (UnsignedIntegerLiteral:h
+ (Whitespace UnsignedIntegerLiteral:i => [[ i ]])*:t
+ => [[ t h prefix ]]
+ )?:elts OptionalWhiteSpace "]" => [[ elts >byte-array ]]
+
+FormalBlockArgumentDeclaration = ":" BindableIdentifier:i => [[ i ]]
+FormalBlockArgumentDeclarationList =
+ FormalBlockArgumentDeclaration:h
+ (Whitespace FormalBlockArgumentDeclaration:v => [[ v ]])*:t
+ => [[ t h prefix ]]
+
+BlockLiteral = "["
+ (OptionalWhiteSpace
+ FormalBlockArgumentDeclarationList:args
+ OptionalWhiteSpace
+ "|"
+ => [[ args ]]
+ )?:args
+ ExecutableCode:body OptionalWhiteSpace
+ "]" => [[ args >array body ast-block boa ]]
+
+Literal = (ConstantReference
+ | FloatingPointLiteral
+ | IntegerLiteral
+ | CharacterLiteral
+ | StringLiteral
+ | ArrayLiteral
+ | SymbolLiteral
+ | BlockLiteral)
+
+NestedExpression = "(" Statement:s OptionalWhiteSpace ")" => [[ s ]]
+Operand = Literal
+ | PseudoVariableReference
+ | Reference
+ | NestedExpression
+
+UnaryMessage = UnaryMessageSelector
+UnaryMessageOperand = UnaryMessageSend | Operand
+UnaryMessageSend = UnaryMessageOperand:receiver
+ OptionalWhiteSpace UnaryMessageSelector:selector !(":")
+ => [[ receiver selector { } ast-message-send boa ]]
+
+BinaryMessage = BinaryMessageSelector OptionalWhiteSpace BinaryMessageOperand
+BinaryMessageOperand = BinaryMessageSend | UnaryMessageSend | Operand
+BinaryMessageSend-1 = BinaryMessageOperand:lhs
+ OptionalWhiteSpace
+ BinaryMessageSelector:selector
+ OptionalWhiteSpace
+ UnaryMessageOperand:rhs
+ => [[ lhs selector { rhs } ast-message-send boa ]]
+BinaryMessageSend = (BinaryMessageSend:lhs
+ OptionalWhiteSpace
+ BinaryMessageSelector:selector
+ OptionalWhiteSpace
+ UnaryMessageOperand:rhs
+ => [[ lhs selector { rhs } ast-message-send boa ]])
+ | BinaryMessageSend-1
+
+KeywordMessageSegment = Keyword:k OptionalWhiteSpace BinaryMessageOperand:arg => [[ { k arg } ]]
+KeywordMessageSend = BinaryMessageOperand:receiver
+ OptionalWhiteSpace
+ KeywordMessageSegment:h
+ (OptionalWhiteSpace KeywordMessageSegment:s => [[ s ]])*:t
+ => [[ receiver t h prefix unzip [ concat ] dip ast-message-send boa ]]
+
+Expression = KeywordMessageSend | BinaryMessageSend | UnaryMessageSend | Operand
+
+AssignmentOperation = OptionalWhiteSpace BindableIdentifier:i
+ OptionalWhiteSpace ":=" OptionalWhiteSpace => [[ i ast-name boa ]]
+AssignmentStatement = AssignmentOperation:a Statement:s => [[ a s ast-assignment boa ]]
+Statement = AssignmentStatement | Expression
+
+MethodReturnOperator = OptionalWhiteSpace "^"
+FinalStatement = (MethodReturnOperator)? Statement:s => [[ s ast-return boa ]]
+
+LocalVariableDeclarationList = OptionalWhiteSpace "|" OptionalWhiteSpace
+ (BindableIdentifier:h
+ (Whitespace BindableIdentifier:b => [[ b ]])*:t
+ => [[ t h prefix ]]
+ )?:b OptionalWhiteSpace "|" => [[ b >array ast-local-variables boa ]]
+
+ExecutableCode = (LocalVariableDeclarationList)?
+ ((Statement:s OptionalWhiteSpace "." => [[ s ]])*
+ FinalStatement:f (".")? => [[ f ]])?
+ => [[ sift >array ]]
+
+UnaryMethodHeader = UnaryMessageSelector:selector
+ => [[ { selector { } } ]]
+BinaryMethodHeader = BinaryMessageSelector:selector OptionalWhiteSpace BindableIdentifier:identifier
+ => [[ { selector { identifier } } ]]
+KeywordMethodHeaderSegment = Keyword:keyword
+ OptionalWhiteSpace
+ BindableIdentifier:identifier => [[ { keyword identifier } ]]
+KeywordMethodHeader = KeywordMethodHeaderSegment:h (Whitespace KeywordMethodHeaderSegment:s => [[ s ]])*:t
+ => [[ t h prefix unzip [ concat ] dip 2array ]]
+MethodHeader = KeywordMethodHeader
+ | BinaryMethodHeader
+ | UnaryMethodHeader
+MethodDeclaration = OptionalWhiteSpace "method" OptionalWhiteSpace MethodHeader:header
+ OptionalWhiteSpace "["
+ ExecutableCode:code
+ OptionalWhiteSpace "]"
+ => [[ header first2 "self" suffix code ast-block boa ast-method boa ]]
+
+ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name
+ OptionalWhiteSpace
+ ("extends" OptionalWhiteSpace Identifier:superclass OptionalWhiteSpace => [[ superclass ]])?:superclass
+ OptionalWhiteSpace "["
+ (OptionalWhiteSpace LocalVariableDeclarationList)?:ivars
+ (MethodDeclaration:h (OptionalWhiteSpace MethodDeclaration:m => [[ m ]])*:t => [[ t h prefix >array ]])?:methods
+ OptionalWhiteSpace "]"
+ => [[ name superclass "Object" or ivars methods ast-class boa ]]
+
+End = !(.)
+
+Program = ClassDeclaration* End
+;EBNF
\ No newline at end of file
diff --git a/extra/smalltalk/parser/test.st b/extra/smalltalk/parser/test.st
new file mode 100644
index 0000000000..7771ee2b9c
--- /dev/null
+++ b/extra/smalltalk/parser/test.st
@@ -0,0 +1,66 @@
+class TreeNode extends Object [
+ |left right item|
+
+ method binarytrees: n to: output [
+ | minDepth maxDepth stretchDepth check longLivedTree iterations |
+ minDepth := 4.
+ maxDepth := minDepth + 2 max: n.
+ stretchDepth := maxDepth + 1.
+
+ check := (TreeNode bottomUpTree: 0 depth: stretchDepth) itemCheck.
+ output
+ nextPutAll: 'stretch tree of depth '; print: stretchDepth; tab;
+ nextPutAll: ' check: '; print: check; nl.
+
+ longLivedTree := TreeNode bottomUpTree: 0 depth: maxDepth.
+ minDepth to: maxDepth by: 2 do: [:depth|
+ iterations := 1 bitShift: maxDepth - depth + minDepth.
+
+ check := 0.
+ 1 to: iterations do: [:i|
+ check := check + (TreeNode bottomUpTree: i depth: depth) itemCheck.
+ check := check + (TreeNode bottomUpTree: -1*i depth: depth) itemCheck
+ ].
+ output
+ print: (2*iterations); tab;
+ nextPutAll: ' trees of depth '; print: depth; tab;
+ nextPutAll: ' check: '; print: check; nl
+ ].
+
+ output
+ nextPutAll: 'long lived tree of depth '; print: maxDepth; tab;
+ nextPutAll: ' check: '; print: longLivedTree itemCheck; nl
+ ]
+
+ binarytrees [
+ self binarytrees: self arg to: self stdout.
+ ^''
+ ]
+
+ method left: leftChild right: rightChild item: anItem [
+ left := leftChild.
+ right := rightChild.
+ item := anItem
+ ]
+
+ method itemCheck [
+ ^left isNil
+ ifTrue: [item] ifFalse: [item + (left itemCheck - right itemCheck)]
+ ]
+
+ method bottomUpTree: anItem depth: anInteger [
+ ^(anInteger > 0)
+ ifTrue: [
+ self
+ left: (self bottomUpTree: 2*anItem - 1 depth: anInteger - 1)
+ right: (self bottomUpTree: 2*anItem depth: anInteger - 1)
+ item: anItem
+ ] ifFalse: [self left: nil right: nil item: anItem]
+ ]
+
+ method left: leftChild right: rightChild item: anItem [
+ ^(super new) left: leftChild right: rightChild item: anItem
+ ]
+]
+
+Tests binarytrees.
diff --git a/extra/smalltalk/selectors/authors.txt b/extra/smalltalk/selectors/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/selectors/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/selectors/selectors.factor b/extra/smalltalk/selectors/selectors.factor
new file mode 100644
index 0000000000..51b2132dbe
--- /dev/null
+++ b/extra/smalltalk/selectors/selectors.factor
@@ -0,0 +1,26 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators effects generic generic.standard
+kernel sequences words ;
+IN: smalltalk.selectors
+
+SYMBOLS: unary binary keyword ;
+
+: selector-type ( selector -- type )
+ {
+ { [ dup [ "+-*/%^&*|@" member? ] all? ] [ binary ] }
+ { [ CHAR: : over member? ] [ keyword ] }
+ [ unary ]
+ } cond nip ;
+
+: selector>effect ( selector -- effect )
+ dup selector-type {
+ { unary [ drop 0 ] }
+ { binary [ drop 1 ] }
+ { keyword [ [ CHAR: : = ] count ] }
+ } case "receiver" suffix { "result" } <effect> ;
+
+: selector>generic ( selector -- generic )
+ [ "selector-" prepend "smalltalk.selectors" create dup ]
+ [ selector>effect ]
+ bi define-simple-generic ;
diff --git a/extra/smalltalk/smalltalk.factor b/extra/smalltalk/smalltalk.factor
new file mode 100644
index 0000000000..27cd9912ed
--- /dev/null
+++ b/extra/smalltalk/smalltalk.factor
@@ -0,0 +1,4 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: ;
+IN: smalltalk
From 42d164db7709f8f0fa125fb17b95df1cd6e37425 Mon Sep 17 00:00:00 2001
From: sheeple <sheeple@oberon.local>
Date: Mon, 30 Mar 2009 07:19:14 -0500
Subject: [PATCH 13/42] Fix C99 complex number support in FFI on Mac OS X/PPC
---
basis/cpu/ppc/ppc.factor | 39 ++++++++++++++++++++++++++++++++++-----
vm/alien.c | 13 ++++++++++++-
vm/alien.h | 1 +
3 files changed, 47 insertions(+), 6 deletions(-)
diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index 8b6b4fbb11..85bf188bb8 100644
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -659,13 +659,40 @@ M: ppc %callback-value ( ctype -- )
M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
-M: ppc return-struct-in-registers? ( c-type -- ? ) drop f ;
+M: ppc return-struct-in-registers? ( c-type -- ? )
+ c-type return-in-registers?>> ;
-M: ppc %box-small-struct
- drop "No small structs" throw ;
+M: ppc %box-small-struct ( c-type -- )
+ #! Box a <= 16-byte struct returned in r3:r4:r5:r6
+ heap-size 7 LI
+ "box_medium_struct" f %alien-invoke ;
-M: ppc %unbox-small-struct
- drop "No small structs" throw ;
+: %unbox-struct-1 ( -- )
+ ! Alien must be in r3.
+ "alien_offset" f %alien-invoke
+ 3 3 0 LWZ ;
+
+: %unbox-struct-2 ( -- )
+ ! Alien must be in r3.
+ "alien_offset" f %alien-invoke
+ 4 3 4 LWZ
+ 3 3 0 LWZ ;
+
+: %unbox-struct-4 ( -- )
+ ! Alien must be in r3.
+ "alien_offset" f %alien-invoke
+ 6 3 12 LWZ
+ 5 3 8 LWZ
+ 4 3 4 LWZ
+ 3 3 0 LWZ ;
+
+M: ppc %unbox-small-struct ( size -- )
+ #! Alien must be in EAX.
+ heap-size cell align cell /i {
+ { 1 [ %unbox-struct-1 ] }
+ { 2 [ %unbox-struct-2 ] }
+ { 4 [ %unbox-struct-4 ] }
+ } case ;
USE: vocabs.loader
@@ -673,3 +700,5 @@ USE: vocabs.loader
{ [ os macosx? ] [ "cpu.ppc.macosx" require ] }
{ [ os linux? ] [ "cpu.ppc.linux" require ] }
} cond
+
+"complex-double" c-type t >>return-in-registers? drop
diff --git a/vm/alien.c b/vm/alien.c
index 8b7df45e9a..2681579c5d 100755
--- a/vm/alien.c
+++ b/vm/alien.c
@@ -160,7 +160,7 @@ void box_value_struct(void *src, CELL size)
dpush(tag_object(array));
}
-/* On OS X, structs <= 8 bytes are returned in registers. */
+/* On some x86 OSes, structs <= 8 bytes are returned in registers. */
void box_small_struct(CELL x, CELL y, CELL size)
{
CELL data[2];
@@ -169,6 +169,17 @@ void box_small_struct(CELL x, CELL y, CELL size)
box_value_struct(data,size);
}
+/* On OS X/PPC, complex numbers are returned in registers. */
+void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size)
+{
+ CELL data[4];
+ data[0] = x1;
+ data[1] = x2;
+ data[2] = x3;
+ data[3] = x4;
+ box_value_struct(data,size);
+}
+
/* open a native library and push a handle */
void primitive_dlopen(void)
{
diff --git a/vm/alien.h b/vm/alien.h
index ec1eb08acf..dc76d49810 100755
--- a/vm/alien.h
+++ b/vm/alien.h
@@ -40,6 +40,7 @@ void primitive_set_alien_cell(void);
DLLEXPORT void to_value_struct(CELL src, void *dest, CELL size);
DLLEXPORT void box_value_struct(void *src, CELL size);
DLLEXPORT void box_small_struct(CELL x, CELL y, CELL size);
+void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size);
DEFINE_UNTAG(F_DLL,DLL_TYPE,dll)
From 6b6de2b8aa36823ed00460cacbaced60fa5dfbd5 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Mon, 30 Mar 2009 19:42:04 -0500
Subject: [PATCH 14/42] refactor some error handling in peg, more unit tests
---
basis/peg/ebnf/ebnf-tests.factor | 12 +++++-
basis/peg/ebnf/ebnf.factor | 72 ++++++++++++++++++++------------
2 files changed, 57 insertions(+), 27 deletions(-)
diff --git a/basis/peg/ebnf/ebnf-tests.factor b/basis/peg/ebnf/ebnf-tests.factor
index a6d3cf0b21..cc83a55c7e 100644
--- a/basis/peg/ebnf/ebnf-tests.factor
+++ b/basis/peg/ebnf/ebnf-tests.factor
@@ -3,7 +3,7 @@
!
USING: kernel tools.test peg peg.ebnf words math math.parser
sequences accessors peg.parsers parser namespaces arrays
- strings eval ;
+ strings eval unicode.data multiline ;
IN: peg.ebnf.tests
{ T{ ebnf-non-terminal f "abc" } } [
@@ -520,3 +520,13 @@ Tok = Spaces (Number | Special )
{ "\\" } [
"\\" [EBNF foo="\\" EBNF]
] unit-test
+
+[ "USE: peg.ebnf [EBNF EBNF]" eval ] must-fail
+
+[ <" USE: peg.ebnf [EBNF
+ lol = a
+ lol = b
+ EBNF] "> eval
+] [
+ error>> [ redefined-rule? ] [ name>> "lol" = ] bi and
+] must-fail-with
diff --git a/basis/peg/ebnf/ebnf.factor b/basis/peg/ebnf/ebnf.factor
index 9f730831e7..b50ba685b8 100644
--- a/basis/peg/ebnf/ebnf.factor
+++ b/basis/peg/ebnf/ebnf.factor
@@ -5,13 +5,18 @@ sequences quotations vectors namespaces make math assocs
continuations peg peg.parsers unicode.categories multiline
splitting accessors effects sequences.deep peg.search
combinators.short-circuit lexer io.streams.string stack-checker
-io combinators parser ;
+io combinators parser summary ;
IN: peg.ebnf
: rule ( name word -- parser )
#! Given an EBNF word produced from EBNF: return the EBNF rule
"ebnf-parser" word-prop at ;
+ERROR: no-rule rule parser ;
+
+: lookup-rule ( rule parser -- rule' )
+ 2dup rule [ 2nip ] [ no-rule ] if* ;
+
TUPLE: tokenizer any one many ;
: default-tokenizer ( -- tokenizer )
@@ -34,8 +39,13 @@ TUPLE: tokenizer any one many ;
: reset-tokenizer ( -- )
default-tokenizer \ tokenizer set-global ;
+ERROR: no-tokenizer name ;
+
+M: no-tokenizer summary
+ drop "Tokenizer not found" ;
+
SYNTAX: TOKENIZER:
- scan search [ "Tokenizer not found" throw ] unless*
+ scan dup search [ nip ] [ no-tokenizer ] if*
execute( -- tokenizer ) \ tokenizer set-global ;
TUPLE: ebnf-non-terminal symbol ;
@@ -258,7 +268,7 @@ DEFER: 'choice'
"]]" token ensure-not ,
"]?" token ensure-not ,
[ drop t ] satisfy ,
- ] seq* [ first ] action repeat0 [ >string ] action ;
+ ] seq* repeat0 [ concat >string ] action ;
: 'ensure-not' ( -- parser )
#! Parses the '!' syntax to ensure that
@@ -367,15 +377,16 @@ M: ebnf-tokenizer (transform) ( ast -- parser )
(transform)
dup parser-tokenizer \ tokenizer set-global
] if ;
+
+ERROR: redefined-rule name ;
+
+M: redefined-rule summary
+ name>> "Rule '" "' defined more than once" surround ;
M: ebnf-rule (transform) ( ast -- parser )
dup elements>>
(transform) [
- swap symbol>> dup get parser? [
- "Rule '" over append "' defined more than once" append throw
- ] [
- set
- ] if
+ swap symbol>> dup get parser? [ redefined-rule ] [ set ] if
] keep ;
M: ebnf-sequence (transform) ( ast -- parser )
@@ -466,14 +477,18 @@ ERROR: bad-effect quot effect ;
{ [ dup (( -- b )) effect<= ] [ drop [ drop ] prepose ] }
[ bad-effect ]
} cond ;
+
+: ebnf-transform ( ast -- parser quot )
+ [ parser>> (transform) ]
+ [ code>> insert-escapes ]
+ [ parser>> ] tri build-locals
+ [ string-lines parse-lines ] call( string -- quot ) ;
M: ebnf-action (transform) ( ast -- parser )
- [ parser>> (transform) ] [ code>> insert-escapes ] [ parser>> ] tri build-locals
- [ string-lines parse-lines ] call( string -- quot ) check-action-effect action ;
+ ebnf-transform check-action-effect action ;
M: ebnf-semantic (transform) ( ast -- parser )
- [ parser>> (transform) ] [ code>> insert-escapes ] [ parser>> ] tri build-locals
- [ string-lines parse-lines ] call( string -- quot ) semantic ;
+ ebnf-transform semantic ;
M: ebnf-var (transform) ( ast -- parser )
parser>> (transform) ;
@@ -481,19 +496,20 @@ M: ebnf-var (transform) ( ast -- parser )
M: ebnf-terminal (transform) ( ast -- parser )
symbol>> tokenizer one>> call( symbol -- parser ) ;
+ERROR: ebnf-foreign-not-found name ;
+
+M: ebnf-foreign-not-found summary
+ name>> "Foreign word '" "' not found" surround ;
+
M: ebnf-foreign (transform) ( ast -- parser )
- dup word>> search
- [ "Foreign word '" swap word>> append "' not found" append throw ] unless*
+ dup word>> search [ word>> ebnf-foreign-not-found ] unless*
swap rule>> [ main ] unless* over rule [
nip
] [
execute( -- parser )
] if* ;
-: parser-not-found ( name -- * )
- [
- "Parser '" % % "' not found." %
- ] "" make throw ;
+ERROR: parser-not-found name ;
M: ebnf-non-terminal (transform) ( ast -- parser )
symbol>> [
@@ -504,16 +520,16 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
'ebnf' parse transform ;
: check-parse-result ( result -- result )
- dup [
- dup remaining>> [ blank? ] trim empty? [
+ [
+ dup remaining>> [ blank? ] trim [
[
"Unable to fully parse EBNF. Left to parse was: " %
remaining>> %
] "" make throw
- ] unless
+ ] unless-empty
] [
"Could not parse EBNF" throw
- ] if ;
+ ] if* ;
: parse-ebnf ( string -- hashtable )
'ebnf' (parse) check-parse-result ast>> transform ;
@@ -522,14 +538,18 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
parse-ebnf dup dup parser [ main swap at compile ] with-variable
[ compiled-parse ] curry [ with-scope ast>> ] curry ;
-SYNTAX: <EBNF "EBNF>" reset-tokenizer parse-multiline-string parse-ebnf main swap at
+SYNTAX: <EBNF
+ "EBNF>"
+ reset-tokenizer parse-multiline-string parse-ebnf main swap at
parsed reset-tokenizer ;
-SYNTAX: [EBNF "EBNF]" reset-tokenizer parse-multiline-string ebnf>quot nip
+SYNTAX: [EBNF
+ "EBNF]"
+ reset-tokenizer parse-multiline-string ebnf>quot nip
parsed \ call parsed reset-tokenizer ;
SYNTAX: EBNF:
reset-tokenizer CREATE-WORD dup ";EBNF" parse-multiline-string
- ebnf>quot swapd (( input -- ast )) define-declared "ebnf-parser" set-word-prop
+ ebnf>quot swapd
+ (( input -- ast )) define-declared "ebnf-parser" set-word-prop
reset-tokenizer ;
-
From 381dbb957c44f8f17cd975329b1ca6f0277cc5dc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 30 Mar 2009 20:45:01 -0500
Subject: [PATCH 15/42] smalltalk: adding a small library, fix various bugs
---
.../smalltalk/compiler/compiler-tests.factor | 105 ++++++++++++------
extra/smalltalk/compiler/compiler.factor | 47 ++++++--
extra/smalltalk/compiler/lexenv/lexenv.factor | 10 +-
extra/smalltalk/library/authors.txt | 1 +
extra/smalltalk/library/library.factor | 75 +++++++++++++
extra/smalltalk/listener/authors.txt | 1 +
extra/smalltalk/listener/listener.factor | 18 +++
extra/smalltalk/parser/parser-tests.factor | 77 ++++++++++++-
extra/smalltalk/parser/parser.factor | 19 +++-
extra/smalltalk/printer/authors.txt | 1 +
extra/smalltalk/printer/printer.factor | 34 ++++++
extra/smalltalk/selectors/selectors.factor | 6 +-
12 files changed, 343 insertions(+), 51 deletions(-)
create mode 100644 extra/smalltalk/library/authors.txt
create mode 100644 extra/smalltalk/library/library.factor
create mode 100644 extra/smalltalk/listener/authors.txt
create mode 100644 extra/smalltalk/listener/listener.factor
create mode 100644 extra/smalltalk/printer/authors.txt
create mode 100644 extra/smalltalk/printer/printer.factor
diff --git a/extra/smalltalk/compiler/compiler-tests.factor b/extra/smalltalk/compiler/compiler-tests.factor
index ee944baf02..a8e918fcf4 100644
--- a/extra/smalltalk/compiler/compiler-tests.factor
+++ b/extra/smalltalk/compiler/compiler-tests.factor
@@ -3,43 +3,82 @@ stack-checker locals.rewrite.closures kernel accessors
compiler.units sequences ;
IN: smalltalk.compiler.tests
-[ 2 1 ] [
+: test-compilation ( ast -- quot )
[
- T{ ast-block f
- { "a" "b" }
- {
- T{ ast-message-send f
- T{ ast-name f "a" }
- "+"
- { T{ ast-name f "b" } }
- }
+ compile-method rewrite-closures first
+ ] with-compilation-unit ;
+
+: test-inference ( ast -- in# out# )
+ test-compilation infer [ in>> ] [ out>> ] bi ;
+
+[ 2 1 ] [
+ T{ ast-block f
+ { "a" "b" }
+ {
+ T{ ast-message-send f
+ T{ ast-name f "a" }
+ "+"
+ { T{ ast-name f "b" } }
}
- } compile-method
- [ . ] [ rewrite-closures first infer [ in>> ] [ out>> ] bi ] bi
- ] with-compilation-unit
+ }
+ } test-inference
] unit-test
[ 3 1 ] [
- [
- T{ ast-block f
- { "a" "b" "c" }
- {
- T{ ast-assignment f
- T{ ast-name f "a" }
- T{ ast-message-send f
- T{ ast-name f "a" }
- "+"
- { T{ ast-name f "b" } }
- }
- }
- T{ ast-message-send f
- T{ ast-name f "b" }
- "blah:"
- { 123.456 }
- }
- T{ ast-return f T{ ast-name f "c" } }
+ T{ ast-block f
+ { "a" "b" "c" }
+ {
+ T{ ast-assignment f
+ T{ ast-name f "a" }
+ T{ ast-message-send f
+ T{ ast-name f "asmal" }
+ "+"
+ { T{ ast-name f "b" } }
+ }
}
- } compile-method
- [ . ] [ rewrite-closures first infer [ in>> ] [ out>> ] bi ] bi
- ] with-compilation-unit
+ T{ ast-message-send f
+ T{ ast-name f "b" }
+ "blah:"
+ { 123.456 }
+ }
+ T{ ast-return f T{ ast-name f "c" } }
+ }
+ } test-inference
+] unit-test
+
+[ 0 1 ] [
+ T{ ast-block f
+ { }
+ {
+ T{ ast-message-send
+ { receiver 1 }
+ { selector "to:do:" }
+ { arguments
+ {
+ 10
+ T{ ast-block
+ { arguments { "i" } }
+ { body
+ {
+ T{ ast-message-send
+ { receiver
+ T{ ast-name { name "i" } }
+ }
+ { selector "print" }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ } test-inference
+] unit-test
+
+[ "a" ] [
+ T{ ast-block f
+ { }
+ { { T{ ast-block { body { "a" } } } } }
+ } test-compilation call first call
] unit-test
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor
index 1f3b0f94e5..b72b218f82 100644
--- a/extra/smalltalk/compiler/compiler.factor
+++ b/extra/smalltalk/compiler/compiler.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators.short-circuit
continuations fry kernel namespaces quotations sequences sets
-slots locals.types generalizations smalltalk.ast
+generalizations slots locals.types generalizations smalltalk.ast
smalltalk.compiler.lexenv smalltalk.selectors ;
IN: smalltalk.compiler
@@ -12,17 +12,19 @@ GENERIC: need-return-continuation? ( ast -- ? )
M: ast-return need-return-continuation? drop t ;
-M: ast-block need-return-continuation? body>> [ need-return-continuation? ] any? ;
+M: ast-block need-return-continuation? body>> need-return-continuation? ;
M: ast-message-send need-return-continuation?
{
[ receiver>> need-return-continuation? ]
- [ arguments>> [ need-return-continuation? ] any? ]
+ [ arguments>> need-return-continuation? ]
} 1&& ;
M: ast-assignment need-return-continuation?
value>> need-return-continuation? ;
+M: array need-return-continuation? [ need-return-continuation? ] any? ;
+
M: object need-return-continuation? drop f ;
GENERIC: assigned-locals ( ast -- seq )
@@ -30,16 +32,20 @@ GENERIC: assigned-locals ( ast -- seq )
M: ast-return assigned-locals value>> assigned-locals ;
M: ast-block assigned-locals
- [ body>> [ assigned-locals ] map concat ] [ arguments>> ] bi diff ;
+ [ body>> assigned-locals ] [ arguments>> ] bi diff ;
M: ast-message-send assigned-locals
+ [ arguments>> assigned-locals ]
[ receiver>> assigned-locals ]
- [ arguments>> [ assigned-locals ] map ] bi append ;
+ bi append ;
M: ast-assignment assigned-locals
[ name>> dup ast-name? [ name>> 1array ] [ drop { } ] if ]
[ value>> assigned-locals ] bi append ;
+M: array assigned-locals
+ [ assigned-locals ] map concat ;
+
M: object assigned-locals drop f ;
GENERIC: compile-ast ( lexenv ast -- quot )
@@ -52,8 +58,8 @@ M: ast-name compile-ast
name>> swap local-readers>> at 1quotation ;
M: ast-message-send compile-ast
+ [ arguments>> [ compile-ast ] with map [ ] join ]
[ receiver>> compile-ast ]
- [ arguments>> [ compile-ast ] with map concat ]
[ nip selector>> selector>generic ]
2tri [ append ] dip suffix ;
@@ -61,6 +67,22 @@ M: ast-return compile-ast
value>> compile-ast
[ return-continuation get continue-with ] append ;
+GENERIC: contains-blocks? ( obj -- ? )
+
+M: ast-block contains-blocks? drop t ;
+
+M: object contains-blocks? drop f ;
+
+M: array contains-blocks? [ contains-blocks? ] any? ;
+
+M: array compile-ast
+ dup contains-blocks? [
+ [ [ compile-ast ] with map [ ] join ] [ length ] bi
+ '[ @ _ narray ]
+ ] [
+ call-next-method
+ ] if ;
+
GENERIC: compile-assignment ( lexenv name -- quot )
M: ast-name compile-assignment
@@ -95,8 +117,15 @@ M: ast-block compile-ast
bi-curry* bi
append
] if-empty
- <lambda> '[ @ ] ;
+ <lambda> '[ _ ] ;
: compile-method ( block -- quot )
- [ [ empty-lexenv ] dip compile-ast ] [ arguments>> length ] [ need-return-continuation? ] tri
- [ '[ [ _ _ ncurry [ return-continuation set ] prepose callcc1 ] with-scope ] ] [ drop ] if ;
\ No newline at end of file
+ [ [ empty-lexenv ] dip compile-ast [ call ] compose ]
+ [ arguments>> length ]
+ [ need-return-continuation? ]
+ tri
+ [ '[ [ _ _ ncurry [ return-continuation set ] prepose callcc1 ] with-scope ] ] [ drop ] if ;
+
+: compile-statement ( statement -- quot )
+ [ [ empty-lexenv ] dip compile-ast ] [ need-return-continuation? ] bi
+ [ '[ [ [ return-continuation set @ ] callcc1 ] with-scope ] ] when ;
diff --git a/extra/smalltalk/compiler/lexenv/lexenv.factor b/extra/smalltalk/compiler/lexenv/lexenv.factor
index 2488a54c5f..2097dc8a50 100644
--- a/extra/smalltalk/compiler/lexenv/lexenv.factor
+++ b/extra/smalltalk/compiler/lexenv/lexenv.factor
@@ -3,9 +3,15 @@
USING: assocs kernel accessors ;
IN: smalltalk.compiler.lexenv
-TUPLE: lexenv local-readers local-writers ;
+! local-readers: assoc string => word
+! local-writers: assoc string => word
+! self: word or f for top-level forms
+! class: class word or f for top-level forms
+! method: generic word or f for top-level forms
+TUPLE: lexenv local-readers local-writers self class method ;
-C: <lexenv> lexenv
+: <lexenv> ( local-readers local-writers -- lexenv )
+ f f f lexenv boa ; inline
CONSTANT: empty-lexenv T{ lexenv }
diff --git a/extra/smalltalk/library/authors.txt b/extra/smalltalk/library/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/library/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/library/library.factor b/extra/smalltalk/library/library.factor
new file mode 100644
index 0000000000..bf455c2c4a
--- /dev/null
+++ b/extra/smalltalk/library/library.factor
@@ -0,0 +1,75 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel present io math sequences assocs math.ranges
+locals smalltalk.selectors smalltalk.ast ;
+IN: smalltalk.library
+
+! Some unary selectors
+SELECTOR: print
+SELECTOR: asString
+
+M: object selector-print dup present print ;
+M: object selector-asString present ;
+
+! Some binary selectors
+SELECTOR: +
+SELECTOR: -
+SELECTOR: *
+SELECTOR: /
+SELECTOR: <
+SELECTOR: >
+SELECTOR: <=
+SELECTOR: >=
+SELECTOR: =
+
+M: object selector-+ swap + ;
+M: object selector-- swap - ;
+M: object selector-* swap * ;
+M: object selector-/ swap / ;
+M: object selector-< swap < ;
+M: object selector-> swap > ;
+M: object selector-<= swap <= ;
+M: object selector->= swap >= ;
+M: object selector-= swap = ;
+
+! Some keyword selectors
+SELECTOR: ifTrue:
+SELECTOR: ifFalse:
+SELECTOR: ifTrue:ifFalse:
+
+M: object selector-ifTrue: [ call( -- result ) ] [ drop nil ] if ;
+M: object selector-ifFalse: [ drop nil ] [ call( -- result ) ] if ;
+M: object selector-ifTrue:ifFalse: [ drop call( -- result ) ] [ nip call( -- result ) ] if ;
+
+SELECTOR: at:
+SELECTOR: at:put:
+
+M: sequence selector-at: nth ;
+M: sequence selector-at:put: ( key value receiver -- receiver ) [ swapd set-nth ] keep ;
+
+M: assoc selector-at: at ;
+M: assoc selector-at:put: ( key value receiver -- receiver ) [ swapd set-at ] keep ;
+
+SELECTOR: do:
+
+M:: object selector-do: ( quot receiver -- nil )
+ receiver [ quot call( elt -- result ) drop ] each nil ;
+
+SELECTOR: to:
+SELECTOR: to:do:
+
+M: object selector-to: swap [a,b] ;
+M:: object selector-to:do: ( to quot from -- nil )
+ from to [a,b] [ quot call( i -- result ) drop ] each nil ;
+
+SELECTOR: value
+SELECTOR: value:
+SELECTOR: value:value:
+SELECTOR: value:value:value:
+SELECTOR: value:value:value:value:
+
+M: object selector-value call( -- result ) ;
+M: object selector-value: call( input -- result ) ;
+M: object selector-value:value: call( input input -- result ) ;
+M: object selector-value:value:value: call( input input input -- result ) ;
+M: object selector-value:value:value:value: call( input input input input -- result ) ;
diff --git a/extra/smalltalk/listener/authors.txt b/extra/smalltalk/listener/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/listener/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/listener/listener.factor b/extra/smalltalk/listener/listener.factor
new file mode 100644
index 0000000000..e1bb6aca5e
--- /dev/null
+++ b/extra/smalltalk/listener/listener.factor
@@ -0,0 +1,18 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel prettyprint io io.styles colors.constants compiler.units
+fry debugger sequences locals.rewrite.closures smalltalk.ast
+smalltalk.parser smalltalk.compiler smalltalk.printer ;
+IN: smalltalk.listener
+
+: eval-smalltalk ( string -- )
+ [
+ parse-smalltalk-statement compile-statement rewrite-closures first
+ ] with-compilation-unit call( -- result )
+ dup nil? [ drop ] [ "Result: " write smalltalk>string print ] if ;
+
+: smalltalk-listener ( -- )
+ "Smalltalk>" { { background COLOR: light-blue } } format bl flush readln
+ [ '[ _ eval-smalltalk ] try smalltalk-listener ] when* ;
+
+MAIN: smalltalk-listener
\ No newline at end of file
diff --git a/extra/smalltalk/parser/parser-tests.factor b/extra/smalltalk/parser/parser-tests.factor
index 9a6614aa07..fa0fde51d6 100644
--- a/extra/smalltalk/parser/parser-tests.factor
+++ b/extra/smalltalk/parser/parser-tests.factor
@@ -53,6 +53,21 @@ test = <foreign parse-smalltalk Literal>
[ T{ ast-block f { "x" } { T{ ast-return f T{ ast-name f "x" } } } } ] [ "[ :x|^x]" test-Literal ] unit-test
[ T{ ast-block f { } { T{ ast-return f self } } } ] [ "[^self]" test-Literal ] unit-test
+[
+ T{ ast-block
+ { arguments { "i" } }
+ { body
+ {
+ T{ ast-message-send
+ { receiver T{ ast-name { name "i" } } }
+ { selector "print" }
+ }
+ }
+ }
+ }
+]
+[ "[ :i | i print ]" test-Literal ] unit-test
+
EBNF: test-FormalBlockArgumentDeclarationList
test = <foreign parse-smalltalk FormalBlockArgumentDeclarationList>
;EBNF
@@ -86,6 +101,24 @@ test = <foreign parse-smalltalk Expression>
]
[ "3 factorial + 4 factorial" test-Expression ] unit-test
+[
+ T{ ast-message-send f
+ T{ ast-message-send f 3 "factorial" { } }
+ "+"
+ { T{ ast-message-send f 4 "factorial" { } } }
+ }
+]
+[ " 3 factorial + 4 factorial" test-Expression ] unit-test
+
+[
+ T{ ast-message-send f
+ T{ ast-message-send f 3 "factorial" { } }
+ "+"
+ { T{ ast-message-send f 4 "factorial" { } } }
+ }
+]
+[ " 3 factorial + 4 factorial " test-Expression ] unit-test
+
[
T{ ast-message-send f
T{ ast-message-send f
@@ -98,13 +131,53 @@ test = <foreign parse-smalltalk Expression>
}
]
[ "(3 factorial + 4) factorial" test-Expression ] unit-test
+
+[
+ T{ ast-message-send
+ { receiver
+ T{ ast-message-send
+ { receiver
+ T{ ast-message-send
+ { receiver 1 }
+ { selector "<" }
+ { arguments { 10 } }
+ }
+ }
+ { selector "ifTrue:ifFalse:" }
+ { arguments
+ {
+ T{ ast-block { body { "HI" } } }
+ T{ ast-block { body { "BYE" } } }
+ }
+ }
+ }
+ }
+ { selector "print" }
+ }
+]
+[ "((1 < 10) ifTrue: [ 'HI' ] ifFalse: [ 'BYE' ]) print" test-Expression ] unit-test
+
+[
+ T{ ast-message-send
+ { receiver
+ T{ ast-message-send
+ { receiver { T{ ast-block { body { "a" } } } } }
+ { selector "at:" }
+ { arguments { 0 } }
+ }
+ }
+ { selector "value" }
+ }
+]
+[ "(#(['a']) at: 0) value" test-Expression ] unit-test
+
EBNF: test-FinalStatement
test = <foreign parse-smalltalk FinalStatement>
;EBNF
-[ T{ ast-return f T{ ast-name f "value" } } ] [ "value" test-FinalStatement ] unit-test
+[ T{ ast-name f "value" } ] [ "value" test-FinalStatement ] unit-test
[ T{ ast-return f T{ ast-name f "value" } } ] [ "^value" test-FinalStatement ] unit-test
-[ T{ ast-return f T{ ast-assignment f T{ ast-name f "value" } 5 } } ] [ "value:=5" test-FinalStatement ] unit-test
+[ T{ ast-assignment f T{ ast-name f "value" } 5 } ] [ "value:=5" test-FinalStatement ] unit-test
EBNF: test-LocalVariableDeclarationList
test = <foreign parse-smalltalk LocalVariableDeclarationList>
diff --git a/extra/smalltalk/parser/parser.factor b/extra/smalltalk/parser/parser.factor
index 2822165938..e2fea234c8 100644
--- a/extra/smalltalk/parser/parser.factor
+++ b/extra/smalltalk/parser/parser.factor
@@ -143,13 +143,15 @@ BinaryMessageSend = (BinaryMessageSend:lhs
| BinaryMessageSend-1
KeywordMessageSegment = Keyword:k OptionalWhiteSpace BinaryMessageOperand:arg => [[ { k arg } ]]
-KeywordMessageSend = BinaryMessageOperand:receiver
+KeywordMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):receiver
OptionalWhiteSpace
KeywordMessageSegment:h
(OptionalWhiteSpace KeywordMessageSegment:s => [[ s ]])*:t
=> [[ receiver t h prefix unzip [ concat ] dip ast-message-send boa ]]
-Expression = KeywordMessageSend | BinaryMessageSend | UnaryMessageSend | Operand
+Expression = OptionalWhiteSpace
+ (KeywordMessageSend | BinaryMessageSend | UnaryMessageSend | Operand):e
+ => [[ e ]]
AssignmentOperation = OptionalWhiteSpace BindableIdentifier:i
OptionalWhiteSpace ":=" OptionalWhiteSpace => [[ i ast-name boa ]]
@@ -157,7 +159,8 @@ AssignmentStatement = AssignmentOperation:a Statement:s => [[ a s ast-assignment
Statement = AssignmentStatement | Expression
MethodReturnOperator = OptionalWhiteSpace "^"
-FinalStatement = (MethodReturnOperator)? Statement:s => [[ s ast-return boa ]]
+FinalStatement = (MethodReturnOperator Statement:s => [[ s ast-return boa ]])
+ | Statement
LocalVariableDeclarationList = OptionalWhiteSpace "|" OptionalWhiteSpace
(BindableIdentifier:h
@@ -200,4 +203,14 @@ ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name
End = !(.)
Program = ClassDeclaration* End
+;EBNF
+
+EBNF: parse-smalltalk-statement
+
+Statement = <foreign parse-smalltalk Statement>
+
+End = !(.)
+
+Program = Statement? => [[ nil or ]] End
+
;EBNF
\ No newline at end of file
diff --git a/extra/smalltalk/printer/authors.txt b/extra/smalltalk/printer/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/printer/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/printer/printer.factor b/extra/smalltalk/printer/printer.factor
new file mode 100644
index 0000000000..70055e8e77
--- /dev/null
+++ b/extra/smalltalk/printer/printer.factor
@@ -0,0 +1,34 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays byte-arrays kernel make math
+math.parser prettyprint sequences smalltalk.ast strings ;
+IN: smalltalk.printer
+
+GENERIC: smalltalk>string ( object -- string )
+
+M: real smalltalk>string number>string ;
+
+M: string smalltalk>string
+ [
+ "'" %
+ [ dup CHAR: ' = [ dup , , ] [ , ] if ] each
+ "'" %
+ ] "" make ;
+
+GENERIC: array-element>string ( object -- string )
+
+M: object array-element>string smalltalk>string ;
+
+M: array array-element>string
+ [ smalltalk>string ] map " " join "(" ")" surround ;
+
+M: array smalltalk>string
+ array-element>string "#" prepend ;
+
+M: byte-array smalltalk>string
+ [ number>string ] { } map-as " " join "#[" "]" surround ;
+
+M: symbol smalltalk>string
+ name>> smalltalk>string "#" prepend ;
+
+M: object smalltalk>string unparse-short ;
\ No newline at end of file
diff --git a/extra/smalltalk/selectors/selectors.factor b/extra/smalltalk/selectors/selectors.factor
index 51b2132dbe..2ea1e99afd 100644
--- a/extra/smalltalk/selectors/selectors.factor
+++ b/extra/smalltalk/selectors/selectors.factor
@@ -1,14 +1,14 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators effects generic generic.standard
-kernel sequences words ;
+kernel sequences words lexer ;
IN: smalltalk.selectors
SYMBOLS: unary binary keyword ;
: selector-type ( selector -- type )
{
- { [ dup [ "+-*/%^&*|@" member? ] all? ] [ binary ] }
+ { [ dup [ "~!@%&*-+=|\\<>,?/" member? ] all? ] [ binary ] }
{ [ CHAR: : over member? ] [ keyword ] }
[ unary ]
} cond nip ;
@@ -24,3 +24,5 @@ SYMBOLS: unary binary keyword ;
[ "selector-" prepend "smalltalk.selectors" create dup ]
[ selector>effect ]
bi define-simple-generic ;
+
+SYNTAX: SELECTOR: scan selector>generic drop ;
\ No newline at end of file
From b32df2100a02c74df2948a16a2f4f53ed5fd4625 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 30 Mar 2009 20:45:55 -0500
Subject: [PATCH 16/42] Fix parse-feed for byte arrays
---
basis/syndication/syndication-docs.factor | 8 ++++----
basis/syndication/syndication-tests.factor | 4 ++--
basis/syndication/syndication.factor | 21 ++++++++++++---------
3 files changed, 18 insertions(+), 15 deletions(-)
diff --git a/basis/syndication/syndication-docs.factor b/basis/syndication/syndication-docs.factor
index 5604a94dbd..47bdc3bb36 100644
--- a/basis/syndication/syndication-docs.factor
+++ b/basis/syndication/syndication-docs.factor
@@ -35,9 +35,9 @@ HELP: download-feed
{ $values { "url" url } { "feed" feed } }
{ $description "Downloads a feed from a URL using the " { $link "http.client" } "." } ;
-HELP: string>feed
-{ $values { "string" string } { "feed" feed } }
-{ $description "Parses a feed in string form." } ;
+HELP: parse-feed
+{ $values { "sequence" "a string or a byte array" } { "feed" feed } }
+{ $description "Parses a feed." } ;
HELP: xml>feed
{ $values { "xml" xml } { "feed" feed } }
@@ -58,7 +58,7 @@ $nl
{ $subsection <entry> }
"Reading feeds:"
{ $subsection download-feed }
-{ $subsection string>feed }
+{ $subsection parse-feed }
{ $subsection xml>feed }
"Writing feeds:"
{ $subsection feed>xml }
diff --git a/basis/syndication/syndication-tests.factor b/basis/syndication/syndication-tests.factor
index 616ce2723a..3ea037352c 100644
--- a/basis/syndication/syndication-tests.factor
+++ b/basis/syndication/syndication-tests.factor
@@ -1,4 +1,4 @@
-USING: syndication io kernel io.files tools.test io.encodings.utf8
+USING: syndication io kernel io.files tools.test io.encodings.binary
calendar urls xml.writer ;
IN: syndication.tests
@@ -8,7 +8,7 @@ IN: syndication.tests
: load-news-file ( filename -- feed )
#! Load an news syndication file and process it, returning
#! it as an feed tuple.
- utf8 file-contents string>feed ;
+ binary file-contents parse-feed ;
[ T{
feed
diff --git a/basis/syndication/syndication.factor b/basis/syndication/syndication.factor
index 9901fd4ce4..3bfc95fe3a 100755
--- a/basis/syndication/syndication.factor
+++ b/basis/syndication/syndication.factor
@@ -1,11 +1,11 @@
! Copyright (C) 2006 Chris Double, Daniel Ehrenberg.
-! Portions copyright (C) 2008 Slava Pestov.
+! Portions copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: xml.traversal kernel assocs math.order
- strings sequences xml.data xml.writer
- io.streams.string combinators xml xml.entities.html io.files io
- http.client namespaces make xml.syntax hashtables
- calendar.format accessors continuations urls present ;
+USING: xml.traversal kernel assocs math.order strings sequences
+xml.data xml.writer io.streams.string combinators xml
+xml.entities.html io.files io http.client namespaces make
+xml.syntax hashtables calendar.format accessors continuations
+urls present byte-arrays ;
IN: syndication
: any-tag-named ( tag names -- tag-inside )
@@ -106,12 +106,15 @@ TUPLE: entry title url description date ;
{ "feed" [ atom1.0 ] }
} case ;
-: string>feed ( string -- feed )
- [ string>xml xml>feed ] with-html-entities ;
+GENERIC: parse-feed ( string -- feed )
+
+M: string parse-feed [ string>xml xml>feed ] with-html-entities ;
+
+M: byte-array parse-feed [ bytes>xml xml>feed ] with-html-entities ;
: download-feed ( url -- feed )
#! Retrieve an news syndication file, return as a feed tuple.
- http-get nip string>feed ;
+ http-get nip parse-feed ;
! Atom generation
From 5b6948aaa5b4c652f0833fbbe74cb8a08d039515 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 31 Mar 2009 01:24:38 -0500
Subject: [PATCH 17/42] smalltalk: working on lexical scoping for instance
variables and class names
---
extra/smalltalk/ast/ast.factor | 2 +
extra/smalltalk/classes/authors.txt | 1 +
extra/smalltalk/classes/classes.factor | 25 ++++++
.../smalltalk/compiler/compiler-tests.factor | 10 +--
extra/smalltalk/compiler/compiler.factor | 88 +++++++++++++------
.../compiler/lexenv/lexenv-tests.factor | 24 +++++
extra/smalltalk/compiler/lexenv/lexenv.factor | 54 ++++++++++--
extra/smalltalk/library/library.factor | 6 +-
extra/smalltalk/listener/listener.factor | 2 +-
extra/smalltalk/parser/parser-tests.factor | 18 ++++
extra/smalltalk/parser/parser.factor | 25 +++---
11 files changed, 199 insertions(+), 56 deletions(-)
create mode 100644 extra/smalltalk/classes/authors.txt
create mode 100644 extra/smalltalk/classes/classes.factor
create mode 100644 extra/smalltalk/compiler/lexenv/lexenv-tests.factor
diff --git a/extra/smalltalk/ast/ast.factor b/extra/smalltalk/ast/ast.factor
index 83e6d0ae84..f426789316 100644
--- a/extra/smalltalk/ast/ast.factor
+++ b/extra/smalltalk/ast/ast.factor
@@ -14,5 +14,7 @@ TUPLE: ast-assignment { name ast-name } value ;
TUPLE: ast-local-variables { names array } ;
TUPLE: ast-method { name string } { body ast-block } ;
TUPLE: ast-class { name string } { superclass string } { ivars array } { methods array } ;
+TUPLE: ast-foreign { class string } { name string } ;
+
TUPLE: symbol { name string } ;
MEMO: intern ( name -- symbol ) symbol boa ;
\ No newline at end of file
diff --git a/extra/smalltalk/classes/authors.txt b/extra/smalltalk/classes/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/classes/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/classes/classes.factor b/extra/smalltalk/classes/classes.factor
new file mode 100644
index 0000000000..1798aad961
--- /dev/null
+++ b/extra/smalltalk/classes/classes.factor
@@ -0,0 +1,25 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces assocs accessors words sequences classes.tuple ;
+IN: smalltalk.classes
+
+SYMBOL: classes
+
+classes [ H{ } clone ] initialize
+
+: create-class ( class -- class )
+ "smalltalk.classes" create ;
+
+ERROR: no-class name ;
+
+: lookup-class ( class -- class )
+ classes get ?at [ ] [ no-class ] if ;
+
+: define-class ( class superclass ivars -- class-word )
+ [ create-class ] [ lookup-class ] [ ] tri*
+ [ define-tuple-class ] [ 2drop dup dup name>> classes get set-at ] 3bi ;
+
+: define-foreign ( class name -- )
+ classes get set-at ;
+
+tuple "Object" define-foreign
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/compiler-tests.factor b/extra/smalltalk/compiler/compiler-tests.factor
index a8e918fcf4..c0b9507dd0 100644
--- a/extra/smalltalk/compiler/compiler-tests.factor
+++ b/extra/smalltalk/compiler/compiler-tests.factor
@@ -1,12 +1,10 @@
USING: smalltalk.compiler tools.test prettyprint smalltalk.ast
-stack-checker locals.rewrite.closures kernel accessors
-compiler.units sequences ;
+smalltalk.compiler.lexenv stack-checker locals.rewrite.closures
+kernel accessors compiler.units sequences ;
IN: smalltalk.compiler.tests
: test-compilation ( ast -- quot )
- [
- compile-method rewrite-closures first
- ] with-compilation-unit ;
+ [ compile-smalltalk [ call ] append ] with-compilation-unit ;
: test-inference ( ast -- in# out# )
test-compilation infer [ in>> ] [ out>> ] bi ;
@@ -31,7 +29,7 @@ IN: smalltalk.compiler.tests
T{ ast-assignment f
T{ ast-name f "a" }
T{ ast-message-send f
- T{ ast-name f "asmal" }
+ T{ ast-name f "c" }
"+"
{ T{ ast-name f "b" } }
}
diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor
index b72b218f82..9c3638ba6c 100644
--- a/extra/smalltalk/compiler/compiler.factor
+++ b/extra/smalltalk/compiler/compiler.factor
@@ -2,8 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators.short-circuit
continuations fry kernel namespaces quotations sequences sets
-generalizations slots locals.types generalizations smalltalk.ast
-smalltalk.compiler.lexenv smalltalk.selectors ;
+generalizations slots locals.types generalizations splitting math
+locals.rewrite.closures generic words smalltalk.ast
+smalltalk.compiler.lexenv smalltalk.selectors
+smalltalk.classes ;
IN: smalltalk.compiler
SYMBOL: return-continuation
@@ -52,10 +54,11 @@ GENERIC: compile-ast ( lexenv ast -- quot )
M: object compile-ast nip 1quotation ;
+M: self compile-ast drop self>> 1quotation ;
+
ERROR: unbound-local name ;
-M: ast-name compile-ast
- name>> swap local-readers>> at 1quotation ;
+M: ast-name compile-ast name>> swap lookup-reader ;
M: ast-message-send compile-ast
[ arguments>> [ compile-ast ] with map [ ] join ]
@@ -79,14 +82,11 @@ M: array compile-ast
dup contains-blocks? [
[ [ compile-ast ] with map [ ] join ] [ length ] bi
'[ @ _ narray ]
- ] [
- call-next-method
- ] if ;
+ ] [ call-next-method ] if ;
GENERIC: compile-assignment ( lexenv name -- quot )
-M: ast-name compile-assignment
- name>> swap local-writers>> at 1quotation ;
+M: ast-name compile-assignment name>> swap lookup-writer ;
M: ast-assignment compile-ast
[ value>> compile-ast [ dup ] ] [ name>> compile-assignment ] 2bi 3append ;
@@ -102,30 +102,62 @@ M: ast-assignment compile-ast
dup
[ nip local-reader? ] assoc-filter
[ <local-writer> ] assoc-map
- <lexenv> ;
+ <lexenv> swap >>local-writers swap >>local-readers ;
-M: ast-block compile-ast
+: compile-block ( lexenv block -- vars body )
[
block-lexenv
[ nip local-readers>> values ]
[ lexenv-union ] 2bi
] [ body>> ] bi
- [ drop [ nil ] ] [
- unclip-last
- [ [ compile-ast [ drop ] append ] with map [ ] join ]
- [ compile-ast ]
- bi-curry* bi
- append
- ] if-empty
- <lambda> '[ _ ] ;
+ [ drop [ nil ] ] [ [ compile-ast ] with map [ drop ] join ] if-empty ;
-: compile-method ( block -- quot )
- [ [ empty-lexenv ] dip compile-ast [ call ] compose ]
- [ arguments>> length ]
- [ need-return-continuation? ]
- tri
- [ '[ [ _ _ ncurry [ return-continuation set ] prepose callcc1 ] with-scope ] ] [ drop ] if ;
+M: ast-block compile-ast
+ compile-block <lambda> '[ _ ] ;
-: compile-statement ( statement -- quot )
- [ [ empty-lexenv ] dip compile-ast ] [ need-return-continuation? ] bi
- [ '[ [ [ return-continuation set @ ] callcc1 ] with-scope ] ] when ;
+: make-return ( quot n block -- quot )
+ need-return-continuation? [
+ '[
+ [
+ _ _ ncurry
+ [ return-continuation set ] prepose callcc1
+ ] with-scope
+ ]
+ ] [ drop ] if
+ rewrite-closures first ;
+
+GENERIC: compile-smalltalk ( ast -- quot )
+
+M: object compile-smalltalk ( statement -- quot )
+ [ [ empty-lexenv ] dip compile-ast 0 ] keep make-return ;
+
+: (compile-method-body) ( lexenv block -- lambda )
+ [ drop self>> ] [ compile-block ] 2bi [ swap suffix ] dip <lambda> ;
+
+: compile-method-body ( lexenv block -- quot )
+ [ [ (compile-method-body) ] [ arguments>> length 1+ ] bi ] keep
+ make-return ;
+
+: compile-method ( lexenv ast-method -- )
+ [ [ class>> ] [ name>> selector>generic ] bi* create-method ]
+ [ body>> compile-method-body ]
+ 2bi define ;
+
+: <class-lexenv> ( class -- lexenv )
+ <lexenv> swap >>class "self" <local-reader> >>self ;
+
+M: ast-class compile-smalltalk ( ast-class -- quot )
+ [
+ [ name>> ] [ superclass>> ] [ ivars>> ] tri
+ define-class <class-lexenv>
+ ]
+ [ methods>> ] bi
+ [ compile-method ] with each
+ [ nil ] ;
+
+ERROR: no-word name ;
+
+M: ast-foreign compile-smalltalk
+ [ class>> dup ":" split1 lookup [ ] [ no-word ] ?if ]
+ [ name>> ] bi define-foreign
+ [ nil ] ;
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/lexenv/lexenv-tests.factor b/extra/smalltalk/compiler/lexenv/lexenv-tests.factor
new file mode 100644
index 0000000000..8f171f3eed
--- /dev/null
+++ b/extra/smalltalk/compiler/lexenv/lexenv-tests.factor
@@ -0,0 +1,24 @@
+USING: smalltalk.compiler.lexenv tools.test kernel namespaces accessors ;
+IN: smalltalk.compiler.lexenv.tests
+
+TUPLE: some-class x y z ;
+
+SYMBOL: fake-self
+
+SYMBOL: fake-local
+
+<lexenv>
+ some-class >>class
+ fake-self >>self
+ H{ { "mumble" fake-local } } >>local-readers
+ H{ { "jumble" fake-local } } >>local-writers
+lexenv set
+
+[ [ fake-local ] ] [ "mumble" lexenv get lookup-reader ] unit-test
+[ [ fake-self x>> ] ] [ "x" lexenv get lookup-reader ] unit-test
+[ [ \ tuple ] ] [ "Object" lexenv get lookup-reader ] unit-test
+
+[ [ fake-local ] ] [ "jumble" lexenv get lookup-writer ] unit-test
+[ [ fake-self (>>y) ] ] [ "y" lexenv get lookup-writer ] unit-test
+
+[ "blahblah" lexenv get lookup-writer ] must-fail
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/lexenv/lexenv.factor b/extra/smalltalk/compiler/lexenv/lexenv.factor
index 2097dc8a50..b204b057b6 100644
--- a/extra/smalltalk/compiler/lexenv/lexenv.factor
+++ b/extra/smalltalk/compiler/lexenv/lexenv.factor
@@ -1,6 +1,8 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs kernel accessors ;
+USING: assocs kernel accessors quotations slots words
+sequences namespaces combinators combinators.short-circuit
+smalltalk.classes ;
IN: smalltalk.compiler.lexenv
! local-readers: assoc string => word
@@ -10,11 +12,53 @@ IN: smalltalk.compiler.lexenv
! method: generic word or f for top-level forms
TUPLE: lexenv local-readers local-writers self class method ;
-: <lexenv> ( local-readers local-writers -- lexenv )
- f f f lexenv boa ; inline
+: <lexenv> ( -- lexenv ) lexenv new ; inline
CONSTANT: empty-lexenv T{ lexenv }
: lexenv-union ( lexenv1 lexenv2 -- lexenv )
- [ [ local-readers>> ] bi@ assoc-union ]
- [ [ local-writers>> ] bi@ assoc-union ] 2bi <lexenv> ;
+ [ <lexenv> ] 2dip {
+ [ [ local-readers>> ] bi@ assoc-union >>local-readers ]
+ [ [ local-writers>> ] bi@ assoc-union >>local-writers ]
+ [ [ self>> ] either? >>self ]
+ [ [ class>> ] either? >>class ]
+ [ [ method>> ] either? >>method ]
+ } 2cleave ;
+
+: local-reader ( name lexenv -- local )
+ local-readers>> at dup [ 1quotation ] when ;
+
+: ivar-reader ( name lexenv -- quot/f )
+ dup class>> [
+ [ class>> "slots" word-prop slot-named ] [ self>> ] bi
+ swap dup [ name>> reader-word [ ] 2sequence ] [ 2drop f ] if
+ ] [ 2drop f ] if ;
+
+: class-name ( name -- quot/f )
+ classes get at dup [ [ ] curry ] when ;
+
+ERROR: bad-identifier name ;
+
+: lookup-reader ( name lexenv -- reader-quot )
+ {
+ [ local-reader ]
+ [ ivar-reader ]
+ [ drop class-name ]
+ [ drop bad-identifier ]
+ } 2|| ;
+
+: local-writer ( name lexenv -- local )
+ local-writers>> at dup [ 1quotation ] when ;
+
+: ivar-writer ( name lexenv -- quot/f )
+ dup class>> [
+ [ class>> "slots" word-prop slot-named ] [ self>> ] bi
+ swap dup [ name>> writer-word [ ] 2sequence ] [ 2drop f ] if
+ ] [ 2drop f ] if ;
+
+: lookup-writer ( name lexenv -- writer-quot )
+ {
+ [ local-writer ]
+ [ ivar-writer ]
+ [ drop bad-identifier ]
+ } 2|| ;
\ No newline at end of file
diff --git a/extra/smalltalk/library/library.factor b/extra/smalltalk/library/library.factor
index bf455c2c4a..1b24db71e8 100644
--- a/extra/smalltalk/library/library.factor
+++ b/extra/smalltalk/library/library.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel present io math sequences assocs math.ranges
-locals smalltalk.selectors smalltalk.ast ;
+locals smalltalk.selectors smalltalk.ast smalltalk.classes ;
IN: smalltalk.library
! Some unary selectors
@@ -73,3 +73,7 @@ M: object selector-value: call( input -- result ) ;
M: object selector-value:value: call( input input -- result ) ;
M: object selector-value:value:value: call( input input input -- result ) ;
M: object selector-value:value:value:value: call( input input input input -- result ) ;
+
+SELECTOR: new
+
+M: object selector-new new ;
\ No newline at end of file
diff --git a/extra/smalltalk/listener/listener.factor b/extra/smalltalk/listener/listener.factor
index e1bb6aca5e..bef4adc196 100644
--- a/extra/smalltalk/listener/listener.factor
+++ b/extra/smalltalk/listener/listener.factor
@@ -7,7 +7,7 @@ IN: smalltalk.listener
: eval-smalltalk ( string -- )
[
- parse-smalltalk-statement compile-statement rewrite-closures first
+ parse-smalltalk compile-smalltalk
] with-compilation-unit call( -- result )
dup nil? [ drop ] [ "Result: " write smalltalk>string print ] if ;
diff --git a/extra/smalltalk/parser/parser-tests.factor b/extra/smalltalk/parser/parser-tests.factor
index fa0fde51d6..aa440f581e 100644
--- a/extra/smalltalk/parser/parser-tests.factor
+++ b/extra/smalltalk/parser/parser-tests.factor
@@ -68,6 +68,13 @@ test = <foreign parse-smalltalk Literal>
]
[ "[ :i | i print ]" test-Literal ] unit-test
+[
+ T{ ast-block
+ { body { 5 self } }
+ }
+]
+[ "[5. self]" test-Literal ] unit-test
+
EBNF: test-FormalBlockArgumentDeclarationList
test = <foreign parse-smalltalk FormalBlockArgumentDeclarationList>
;EBNF
@@ -207,4 +214,15 @@ test = <foreign parse-smalltalk KeywordMessageSend>
]
[ "3 factorial + 4 factorial between: 10 and: 100" test-KeywordMessageSend ] unit-test
+[ { 1 2 } ] [ "1. 2" parse-smalltalk ] unit-test
+
+[
+ T{ ast-class
+ { name "Test" }
+ { superclass "Object" }
+ { ivars { "a" } }
+ }
+]
+[ "class Test [|a|]" parse-smalltalk ] unit-test
+
[ ] [ "vocab:smalltalk/parser/test.st" ascii file-contents parse-smalltalk drop ] unit-test
diff --git a/extra/smalltalk/parser/parser.factor b/extra/smalltalk/parser/parser.factor
index e2fea234c8..e153e1552d 100644
--- a/extra/smalltalk/parser/parser.factor
+++ b/extra/smalltalk/parser/parser.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: peg peg.ebnf smalltalk.ast sequences sequences.deep strings
-math.parser kernel arrays byte-arrays math assocs ;
+math.parser kernel arrays byte-arrays math assocs accessors ;
IN: smalltalk.parser
! Based on http://chronos-st.blogspot.com/2007/12/smalltalk-in-one-page.html
@@ -189,28 +189,23 @@ MethodDeclaration = OptionalWhiteSpace "method" OptionalWhiteSpace MethodHeader:
OptionalWhiteSpace "["
ExecutableCode:code
OptionalWhiteSpace "]"
- => [[ header first2 "self" suffix code ast-block boa ast-method boa ]]
+ => [[ header first2 code ast-block boa ast-method boa ]]
ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name
OptionalWhiteSpace
("extends" OptionalWhiteSpace Identifier:superclass OptionalWhiteSpace => [[ superclass ]])?:superclass
OptionalWhiteSpace "["
- (OptionalWhiteSpace LocalVariableDeclarationList)?:ivars
- (MethodDeclaration:h (OptionalWhiteSpace MethodDeclaration:m => [[ m ]])*:t => [[ t h prefix >array ]])?:methods
+ (OptionalWhiteSpace LocalVariableDeclarationList:l => [[ l names>> ]])?:ivars
+ (MethodDeclaration:h (OptionalWhiteSpace MethodDeclaration:m => [[ m ]])*:t => [[ t h prefix ]])?:methods
OptionalWhiteSpace "]"
- => [[ name superclass "Object" or ivars methods ast-class boa ]]
+ => [[ name superclass "Object" or ivars >array methods >array ast-class boa ]]
+ForeignClassDeclaration = OptionalWhiteSpace "foreign"
+ OptionalWhiteSpace Identifier:name
+ OptionalWhiteSpace Literal:class
+ => [[ class name ast-foreign boa ]]
End = !(.)
-Program = ClassDeclaration* End
-;EBNF
-
-EBNF: parse-smalltalk-statement
-
-Statement = <foreign parse-smalltalk Statement>
-
-End = !(.)
-
-Program = Statement? => [[ nil or ]] End
+Program = (ClassDeclaration|ForeignClassDeclaration|ExecutableCode) => [[ nil or ]] End
;EBNF
\ No newline at end of file
From 712b21b59e14c78e387b3e6cd17fb0471ed46960 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 31 Mar 2009 01:37:05 -0500
Subject: [PATCH 18/42] Fix printing of nested arrays
---
extra/smalltalk/printer/printer-tests.factor | 4 ++++
extra/smalltalk/printer/printer.factor | 2 +-
2 files changed, 5 insertions(+), 1 deletion(-)
create mode 100644 extra/smalltalk/printer/printer-tests.factor
diff --git a/extra/smalltalk/printer/printer-tests.factor b/extra/smalltalk/printer/printer-tests.factor
new file mode 100644
index 0000000000..e9f4bd9451
--- /dev/null
+++ b/extra/smalltalk/printer/printer-tests.factor
@@ -0,0 +1,4 @@
+IN: smalltalk.printer.tests
+USING: smalltalk.printer tools.test ;
+
+[ "#((1 2) 'hi')" ] [ { { 1 2 } "hi" } smalltalk>string ] unit-test
\ No newline at end of file
diff --git a/extra/smalltalk/printer/printer.factor b/extra/smalltalk/printer/printer.factor
index 70055e8e77..9b6aa11114 100644
--- a/extra/smalltalk/printer/printer.factor
+++ b/extra/smalltalk/printer/printer.factor
@@ -20,7 +20,7 @@ GENERIC: array-element>string ( object -- string )
M: object array-element>string smalltalk>string ;
M: array array-element>string
- [ smalltalk>string ] map " " join "(" ")" surround ;
+ [ array-element>string ] map " " join "(" ")" surround ;
M: array smalltalk>string
array-element>string "#" prepend ;
From 85fb4aab89d2d9940ba5e71f292f640629c7cb11 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 31 Mar 2009 04:43:26 -0500
Subject: [PATCH 19/42] syndication: fix help lint
---
basis/syndication/syndication-docs.factor | 2 +-
basis/syndication/syndication.factor | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/syndication/syndication-docs.factor b/basis/syndication/syndication-docs.factor
index 47bdc3bb36..bc9612f55c 100644
--- a/basis/syndication/syndication-docs.factor
+++ b/basis/syndication/syndication-docs.factor
@@ -36,7 +36,7 @@ HELP: download-feed
{ $description "Downloads a feed from a URL using the " { $link "http.client" } "." } ;
HELP: parse-feed
-{ $values { "sequence" "a string or a byte array" } { "feed" feed } }
+{ $values { "seq" "a string or a byte array" } { "feed" feed } }
{ $description "Parses a feed." } ;
HELP: xml>feed
diff --git a/basis/syndication/syndication.factor b/basis/syndication/syndication.factor
index 3bfc95fe3a..e30cd6826c 100755
--- a/basis/syndication/syndication.factor
+++ b/basis/syndication/syndication.factor
@@ -106,7 +106,7 @@ TUPLE: entry title url description date ;
{ "feed" [ atom1.0 ] }
} case ;
-GENERIC: parse-feed ( string -- feed )
+GENERIC: parse-feed ( seq -- feed )
M: string parse-feed [ string>xml xml>feed ] with-html-entities ;
From 1dfa621f4db3ccb5dafbe10c69f9e2e17869612b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 31 Mar 2009 08:03:27 -0500
Subject: [PATCH 20/42] Tweak some code to reduce deployed image size
---
basis/cocoa/application/application.factor | 2 +-
basis/core-foundation/strings/strings.factor | 4 ++--
basis/io/encodings/ascii/ascii.factor | 6 ++----
basis/io/encodings/iana/iana.factor | 5 ++++-
basis/tools/deploy/shaker/shaker.factor | 1 +
5 files changed, 10 insertions(+), 8 deletions(-)
diff --git a/basis/cocoa/application/application.factor b/basis/cocoa/application/application.factor
index 9437051dad..8b33986fc2 100644
--- a/basis/cocoa/application/application.factor
+++ b/basis/cocoa/application/application.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax io kernel namespaces core-foundation
core-foundation.strings cocoa.messages cocoa cocoa.classes
-cocoa.runtime sequences threads init summary kernel.private
+cocoa.runtime sequences init summary kernel.private
assocs ;
IN: cocoa.application
diff --git a/basis/core-foundation/strings/strings.factor b/basis/core-foundation/strings/strings.factor
index 21f3d7efd4..413709d142 100644
--- a/basis/core-foundation/strings/strings.factor
+++ b/basis/core-foundation/strings/strings.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax alien.strings io.encodings.string kernel
sequences byte-arrays io.encodings.utf8 math core-foundation
-core-foundation.arrays destructors unicode.data ;
+core-foundation.arrays destructors ;
IN: core-foundation.strings
TYPEDEF: void* CFStringRef
@@ -62,7 +62,7 @@ FUNCTION: CFStringRef CFStringCreateWithCString (
: prepare-CFString ( string -- byte-array )
[
dup HEX: 10ffff >
- [ drop CHAR: replacement-character ] when
+ [ drop HEX: fffd ] when
] map utf8 encode ;
: <CFString> ( string -- alien )
diff --git a/basis/io/encodings/ascii/ascii.factor b/basis/io/encodings/ascii/ascii.factor
index deb1a7121f..1654cb8b83 100644
--- a/basis/io/encodings/ascii/ascii.factor
+++ b/basis/io/encodings/ascii/ascii.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: io io.encodings kernel math io.encodings.private io.encodings.iana ;
+USING: io io.encodings kernel math io.encodings.private ;
IN: io.encodings.ascii
<PRIVATE
@@ -19,6 +19,4 @@ M: ascii encode-char
128 encode-if< ;
M: ascii decode-char
- 128 decode-if< ;
-
-ascii "ANSI_X3.4-1968" register-encoding
+ 128 decode-if< ;
\ No newline at end of file
diff --git a/basis/io/encodings/iana/iana.factor b/basis/io/encodings/iana/iana.factor
index cb4627460c..899bedfbc6 100644
--- a/basis/io/encodings/iana/iana.factor
+++ b/basis/io/encodings/iana/iana.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2008 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: kernel strings values io.files assocs
-splitting sequences io namespaces sets io.encodings.utf8 ;
+splitting sequences io namespaces sets
+io.encodings.ascii io.encodings.utf8 ;
IN: io.encodings.iana
<PRIVATE
@@ -52,3 +53,5 @@ e>n-table [ initial-e>n ] initialize
[ n>e-table get-global set-at ] with each
] [ "Bad encoding registration" throw ] if*
] [ swap e>n-table get-global set-at ] 2bi ;
+
+ascii "ANSI_X3.4-1968" register-encoding
diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor
index 55433299ad..8ee0393091 100755
--- a/basis/tools/deploy/shaker/shaker.factor
+++ b/basis/tools/deploy/shaker/shaker.factor
@@ -157,6 +157,7 @@ IN: tools.deploy.shaker
"specializer"
"step-into"
"step-into?"
+ "superclass"
"transform-n"
"transform-quot"
"tuple-dispatch-generic"
From 39b53817b948b69e8d61525a03fb20f78b970946 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 31 Mar 2009 08:15:27 -0500
Subject: [PATCH 21/42] Small size reduction for deployed images
---
basis/compiler/codegen/codegen.factor | 2 +-
vm/callstack.c | 2 +-
vm/code_block.c | 11 +++++------
vm/code_block.h | 5 ++++-
vm/debug.c | 11 +++++++----
vm/quotations.c | 3 ++-
6 files changed, 20 insertions(+), 14 deletions(-)
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 7df80c6b6e..65e70bd042 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -53,7 +53,7 @@ SYMBOL: labels
V{ } clone literal-table set
V{ } clone calls set
compiling-word set
- compiled-stack-traces? compiling-word get f ? add-literal ;
+ compiled-stack-traces? [ compiling-word get add-literal ] when ;
: generate ( mr -- asm )
[
diff --git a/vm/callstack.c b/vm/callstack.c
index d44a889756..b7e6b946bb 100755
--- a/vm/callstack.c
+++ b/vm/callstack.c
@@ -103,7 +103,7 @@ CELL frame_type(F_STACK_FRAME *frame)
CELL frame_executing(F_STACK_FRAME *frame)
{
F_CODE_BLOCK *compiled = frame_code(frame);
- if(compiled->literals == F)
+ if(compiled->literals == F || !stack_traces_p())
return F;
else
{
diff --git a/vm/code_block.c b/vm/code_block.c
index c6ecb2f431..8dda8bc16e 100644
--- a/vm/code_block.c
+++ b/vm/code_block.c
@@ -11,7 +11,7 @@ void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter)
{
F_BYTE_ARRAY *relocation = untag_object(compiled->relocation);
- CELL index = 1;
+ CELL index = stack_traces_p() ? 1 : 0;
F_REL *rel = (F_REL *)(relocation + 1);
F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation));
@@ -368,11 +368,6 @@ void deposit_integers(CELL here, F_ARRAY *array, CELL format)
}
}
-bool stack_traces_p(void)
-{
- return to_boolean(userenv[STACK_TRACES_ENV]);
-}
-
CELL compiled_code_format(void)
{
return untag_fixnum_fast(userenv[JIT_CODE_FORMAT]);
@@ -429,6 +424,10 @@ F_CODE_BLOCK *add_code_block(
UNREGISTER_ROOT(relocation);
UNREGISTER_ROOT(literals);
+ /* slight space optimization */
+ if(type_of(literals) == ARRAY_TYPE && array_capacity(untag_object(literals)) == 0)
+ literals = F;
+
/* compiled header */
compiled->block.type = type;
compiled->block.last_scan = NURSERY;
diff --git a/vm/code_block.h b/vm/code_block.h
index b00e4be8b6..cb8ebf5e19 100644
--- a/vm/code_block.h
+++ b/vm/code_block.h
@@ -75,7 +75,10 @@ void relocate_code_block(F_CODE_BLOCK *relocating);
CELL compiled_code_format(void);
-bool stack_traces_p(void);
+INLINE bool stack_traces_p(void)
+{
+ return userenv[STACK_TRACES_ENV] != F;
+}
F_CODE_BLOCK *add_code_block(
CELL type,
diff --git a/vm/debug.c b/vm/debug.c
index adae1cdd36..6f7e883785 100755
--- a/vm/debug.c
+++ b/vm/debug.c
@@ -311,7 +311,7 @@ void find_data_references(CELL look_for_)
/* Dump all code blocks for debugging */
void dump_code_heap(void)
{
- CELL size = 0;
+ CELL reloc_size = 0, literal_size = 0;
F_BLOCK *scan = first_block(&code_heap);
@@ -324,11 +324,13 @@ void dump_code_heap(void)
status = "free";
break;
case B_ALLOCATED:
- size += object_size(((F_CODE_BLOCK *)scan)->relocation);
+ reloc_size += object_size(((F_CODE_BLOCK *)scan)->relocation);
+ literal_size += object_size(((F_CODE_BLOCK *)scan)->literals);
status = "allocated";
break;
case B_MARKED:
- size += object_size(((F_CODE_BLOCK *)scan)->relocation);
+ reloc_size += object_size(((F_CODE_BLOCK *)scan)->relocation);
+ literal_size += object_size(((F_CODE_BLOCK *)scan)->literals);
status = "marked";
break;
default:
@@ -343,7 +345,8 @@ void dump_code_heap(void)
scan = next_block(&code_heap,scan);
}
- print_cell(size); print_string(" bytes of relocation data\n");
+ print_cell(reloc_size); print_string(" bytes of relocation data\n");
+ print_cell(literal_size); print_string(" bytes of literal data\n");
}
void factorbug(void)
diff --git a/vm/quotations.c b/vm/quotations.c
index 86e47745b7..e18e6b6098 100755
--- a/vm/quotations.c
+++ b/vm/quotations.c
@@ -180,7 +180,8 @@ void jit_compile(CELL quot, bool relocate)
GROWABLE_ARRAY(literals);
REGISTER_ROOT(literals);
- GROWABLE_ARRAY_ADD(literals,stack_traces_p() ? quot : F);
+ if(stack_traces_p())
+ GROWABLE_ARRAY_ADD(literals,quot);
bool stack_frame = jit_stack_frame_p(untag_object(array));
From 932d44cab8d62f2add4187ac4c3d88f98009f00e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 31 Mar 2009 08:16:04 -0500
Subject: [PATCH 22/42] Small speedup for code using H{ } clone and with-scope
---
.../compiler/tree/propagation/known-words/known-words.factor | 2 +-
basis/hints/hints.factor | 2 +-
core/hashtables/hashtables.factor | 4 ++--
core/namespaces/namespaces.factor | 2 +-
4 files changed, 5 insertions(+), 5 deletions(-)
diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor
index ecfd415579..1b5d383353 100644
--- a/basis/compiler/tree/propagation/known-words/known-words.factor
+++ b/basis/compiler/tree/propagation/known-words/known-words.factor
@@ -312,7 +312,7 @@ generic-comparison-ops [
\ clone [
in-d>> first value-info literal>> {
{ V{ } [ [ drop { } 0 vector boa ] ] }
- { H{ } [ [ drop hashtable new ] ] }
+ { H{ } [ [ drop 0 <hashtable> ] ] }
[ drop f ]
} case
] "custom-inlining" set-word-prop
diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor
index 597367c353..804ef035f4 100644
--- a/basis/hints/hints.factor
+++ b/basis/hints/hints.factor
@@ -119,6 +119,6 @@ SYNTAX: HINTS:
\ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop
-\ hashtable \ at* method { { fixnum hashtable } { word hashtable } } "specializer" set-word-prop
+\ hashtable \ at* method { { fixnum object } { word object } } "specializer" set-word-prop
\ hashtable \ set-at method { { object fixnum object } { object word object } } "specializer" set-word-prop
diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor
index 8aa13a5f5e..f95a7a7e67 100644
--- a/core/hashtables/hashtables.factor
+++ b/core/hashtables/hashtables.factor
@@ -79,7 +79,7 @@ TUPLE: hashtable
: grow-hash ( hash -- )
[ [ >alist ] [ assoc-size 1+ ] bi ] keep
[ reset-hash ] keep
- swap (rehash) ; inline
+ swap (rehash) ;
: ?grow-hash ( hash -- )
dup hash-large? [
@@ -95,7 +95,7 @@ TUPLE: hashtable
PRIVATE>
: <hashtable> ( n -- hash )
- hashtable new [ reset-hash ] keep ;
+ hashtable new [ reset-hash ] keep ; inline
M: hashtable at* ( key hash -- value ? )
key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ;
diff --git a/core/namespaces/namespaces.factor b/core/namespaces/namespaces.factor
index 623e2ddcda..b0e764c94d 100644
--- a/core/namespaces/namespaces.factor
+++ b/core/namespaces/namespaces.factor
@@ -30,6 +30,6 @@ PRIVATE>
: bind ( ns quot -- ) swap >n call ndrop ; inline
: counter ( variable -- n ) global [ 0 or 1+ dup ] change-at ;
: make-assoc ( quot exemplar -- hash ) 20 swap new-assoc [ swap bind ] keep ; inline
-: with-scope ( quot -- ) H{ } clone swap bind ; inline
+: with-scope ( quot -- ) 5 <hashtable> swap bind ; inline
: with-variable ( value key quot -- ) [ associate ] dip bind ; inline
: initialize ( variable quot -- ) [ global ] dip [ unless* ] curry change-at ; inline
\ No newline at end of file
From 65cb08c3550962672a03d14ae76ae23da6d224c4 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 31 Mar 2009 11:12:05 -0500
Subject: [PATCH 23/42] fix help-lint for syndication
---
basis/syndication/syndication.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/syndication/syndication.factor b/basis/syndication/syndication.factor
index 3bfc95fe3a..75c1824c78 100755
--- a/basis/syndication/syndication.factor
+++ b/basis/syndication/syndication.factor
@@ -106,7 +106,7 @@ TUPLE: entry title url description date ;
{ "feed" [ atom1.0 ] }
} case ;
-GENERIC: parse-feed ( string -- feed )
+GENERIC: parse-feed ( sequence -- feed )
M: string parse-feed [ string>xml xml>feed ] with-html-entities ;
From a07c17598efaaffee33c146464573d184042c53c Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Tue, 31 Mar 2009 16:04:39 -0500
Subject: [PATCH 24/42] redo state parser to avoid dynamic variables
---
extra/html/parser/state/state-tests.factor | 34 +++++++---
extra/html/parser/state/state.factor | 73 ++++++++++++++--------
2 files changed, 72 insertions(+), 35 deletions(-)
diff --git a/extra/html/parser/state/state-tests.factor b/extra/html/parser/state/state-tests.factor
index da70d0fa12..f676649aa8 100644
--- a/extra/html/parser/state/state-tests.factor
+++ b/extra/html/parser/state/state-tests.factor
@@ -1,14 +1,30 @@
-USING: tools.test html.parser.state ascii kernel ;
+USING: tools.test html.parser.state ascii kernel accessors ;
IN: html.parser.state.tests
-: take-rest ( -- string )
- [ f ] take-until ;
+[ "hello" ]
+[ "hello" [ take-rest ] string-parse ] unit-test
-: take-char ( -- string )
- [ get-char = ] curry take-until ;
+[ "hi" " how are you?" ]
+[
+ "hi how are you?"
+ [ [ [ blank? ] take-until ] [ take-rest ] bi ] string-parse
+] unit-test
+
+[ "foo" ";bar" ]
+[
+ "foo;bar" [
+ [ CHAR: ; take-until-char ] [ take-rest ] bi
+ ] string-parse
+] unit-test
-[ "hello" ] [ "hello" [ take-rest ] string-parse ] unit-test
-[ "hi" " how are you?" ] [ "hi how are you?" [ [ get-char blank? ] take-until take-rest ] string-parse ] unit-test
-[ "foo" ";bar" ] [ "foo;bar" [ CHAR: ; take-char take-rest ] string-parse ] unit-test
[ "foo " " bar" ]
-[ "foo and bar" [ "and" take-string take-rest ] string-parse ] unit-test
+[
+ "foo and bar" [
+ [ "and" take-until-string ] [ take-rest ] bi
+ ] string-parse
+] unit-test
+
+[ 6 ]
+[
+ " foo " [ skip-whitespace i>> ] string-parse
+] unit-test
diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor
index 1b3f188a78..c69fd76af5 100644
--- a/extra/html/parser/state/state.factor
+++ b/extra/html/parser/state/state.factor
@@ -1,41 +1,62 @@
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces math kernel sequences accessors fry circular ;
+USING: namespaces math kernel sequences accessors fry circular
+unicode.case unicode.categories locals ;
IN: html.parser.state
-TUPLE: state string i ;
+TUPLE: state-parser string i ;
-: get-i ( -- i ) state get i>> ; inline
+: <state-parser> ( string -- state-parser )
+ state-parser new
+ swap >>string
+ 0 >>i ;
-: get-char ( -- char )
- state get [ i>> ] [ string>> ] bi ?nth ; inline
+: (get-char) ( i state -- char/f )
+ string>> ?nth ; inline
-: get-next ( -- char )
- state get [ i>> 1+ ] [ string>> ] bi ?nth ; inline
+: get-char ( state -- char/f )
+ [ i>> ] keep (get-char) ; inline
-: next ( -- )
- state get [ 1+ ] change-i drop ; inline
+: get-next ( state -- char/f )
+ [ i>> 1+ ] keep (get-char) ; inline
+
+: next ( state -- state )
+ [ 1+ ] change-i ; inline
+
+: get+increment ( state -- char/f )
+ [ get-char ] [ next drop ] bi ; inline
: string-parse ( string quot -- )
- [ 0 state boa state ] dip with-variable ; inline
+ [ <state-parser> ] dip call ; inline
-: short* ( n seq -- n' seq )
- over [ nip dup length swap ] unless ; inline
+:: skip-until ( state quot: ( obj -- ? ) -- )
+ state get-char [
+ quot call [ state next quot skip-until ] unless
+ ] when* ; inline recursive
-: skip-until ( quot: ( -- ? ) -- )
- get-char [
- [ call ] keep swap
- [ drop ] [ next skip-until ] if
- ] [ drop ] if ; inline recursive
+: take-until ( state quot: ( obj -- ? ) -- string )
+ [ drop i>> ]
+ [ skip-until ]
+ [ drop [ i>> ] [ string>> ] bi ] 2tri subseq ; inline
-: take-until ( quot: ( -- ? ) -- )
- get-i [ skip-until ] dip get-i
- state get string>> subseq ; inline
+:: take-until-string ( state-parser string -- string' )
+ string length <growing-circular> :> growing
+ state-parser
+ [
+ growing push-growing-circular
+ string growing sequence=
+ ] take-until :> found
+ found dup length
+ growing length 1- - head
+ state-parser next drop ;
+
+: skip-whitespace ( state -- state )
+ [ [ blank? not ] take-until drop ] keep ;
-: string-matches? ( string circular -- ? )
- get-char over push-growing-circular sequence= ; inline
+: take-rest ( state -- string )
+ [ drop f ] take-until ; inline
-: take-string ( match -- string )
- dup length <growing-circular>
- [ 2dup string-matches? ] take-until nip
- dup length rot length 1- - head next ; inline
+: take-until-char ( state ch -- string )
+ '[ _ = ] take-until ;
+
+: string-parse-end? ( state -- ? ) get-next not ;
From ebddd32677f92efda0715e9b1817288a4dc3d447 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Tue, 31 Mar 2009 16:05:11 -0500
Subject: [PATCH 25/42] remove duplication, refactor html.parser to use new
state parser
---
extra/html/parser/parser.factor | 145 ++++++++++-----------
extra/html/parser/utils/utils-tests.factor | 9 +-
extra/html/parser/utils/utils.factor | 16 +--
3 files changed, 69 insertions(+), 101 deletions(-)
diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor
index 60e5ddbf54..677737618b 100644
--- a/extra/html/parser/parser.factor
+++ b/extra/html/parser/parser.factor
@@ -1,10 +1,12 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays html.parser.utils hashtables io kernel
-namespaces make prettyprint quotations sequences splitting
-html.parser.state strings unicode.categories unicode.case ;
+USING: accessors arrays hashtables html.parser.state
+html.parser.utils kernel make namespaces sequences
+unicode.case unicode.categories combinators.short-circuit
+quoting ;
IN: html.parser
+
TUPLE: tag name attributes text closing? ;
SINGLETON: text
@@ -28,113 +30,100 @@ SYMBOL: tagstack
: make-tag ( string attribs -- tag )
[ [ closing-tag? ] keep "/" trim1 ] dip rot <tag> ;
-: make-text-tag ( string -- tag )
+: new-tag ( string type -- tag )
tag new
- text >>name
- swap >>text ;
+ swap >>name
+ swap >>text ; inline
-: make-comment-tag ( string -- tag )
- tag new
- comment >>name
- swap >>text ;
+: make-text-tag ( string -- tag ) text new-tag ; inline
-: make-dtd-tag ( string -- tag )
- tag new
- dtd >>name
- swap >>text ;
+: make-comment-tag ( string -- tag ) comment new-tag ; inline
-: read-whitespace ( -- string )
- [ get-char blank? not ] take-until ;
+: make-dtd-tag ( string -- tag ) dtd new-tag ; inline
-: read-whitespace* ( -- ) read-whitespace drop ;
+: read-single-quote ( state-parser -- string )
+ [ [ CHAR: ' = ] take-until ] [ next drop ] bi ;
-: read-token ( -- string )
- read-whitespace*
- [ get-char blank? ] take-until ;
+: read-double-quote ( state-parser -- string )
+ [ [ CHAR: " = ] take-until ] [ next drop ] bi ;
-: read-single-quote ( -- string )
- [ get-char CHAR: ' = ] take-until ;
+: read-quote ( state-parser -- string )
+ dup get+increment CHAR: ' =
+ [ read-single-quote ] [ read-double-quote ] if ;
-: read-double-quote ( -- string )
- [ get-char CHAR: " = ] take-until ;
+: read-key ( state-parser -- string )
+ skip-whitespace
+ [ { [ CHAR: = = ] [ blank? ] } 1|| ] take-until ;
-: read-quote ( -- string )
- get-char next CHAR: ' =
- [ read-single-quote ] [ read-double-quote ] if next ;
+: read-= ( state-parser -- )
+ skip-whitespace
+ [ [ CHAR: = = ] take-until drop ] [ next drop ] bi ;
-: read-key ( -- string )
- read-whitespace*
- [ get-char [ CHAR: = = ] [ blank? ] bi or ] take-until ;
+: read-token ( state-parser -- string )
+ [ blank? ] take-until ;
-: read-= ( -- )
- read-whitespace*
- [ get-char CHAR: = = ] take-until drop next ;
-
-: read-value ( -- string )
- read-whitespace*
- get-char quote? [ read-quote ] [ read-token ] if
+: read-value ( state-parser -- string )
+ skip-whitespace
+ dup get-char quote? [ read-quote ] [ read-token ] if
[ blank? ] trim ;
-: read-comment ( -- )
- "-->" take-string make-comment-tag push-tag ;
+: read-comment ( state-parser -- )
+ "-->" take-until-string make-comment-tag push-tag ;
-: read-dtd ( -- )
- ">" take-string make-dtd-tag push-tag ;
+: read-dtd ( state-parser -- )
+ ">" take-until-string make-dtd-tag push-tag ;
-: read-bang ( -- )
- next get-char CHAR: - = get-next CHAR: - = and [
+: read-bang ( state-parser -- )
+ next dup { [ get-char CHAR: - = ] [ get-next CHAR: - = ] } 1&& [
next next
read-comment
] [
read-dtd
] if ;
-: read-tag ( -- string )
- [ get-char CHAR: > = get-char CHAR: < = or ] take-until
- get-char CHAR: < = [ next ] unless ;
+: read-tag ( state-parser -- string )
+ [ [ "><" member? ] take-until ]
+ [ dup get-char CHAR: < = [ next ] unless drop ] bi ;
-: read-< ( -- string )
- next get-char CHAR: ! = [
- read-bang f
+: read-until-< ( state-parser -- string )
+ [ CHAR: < = ] take-until ;
+
+: parse-text ( state-parser -- )
+ read-until-< [ make-text-tag push-tag ] unless-empty ;
+
+: (parse-attributes) ( state-parser -- )
+ skip-whitespace
+ dup string-parse-end? [
+ drop
] [
- read-tag
+ [
+ [ read-key >lower ] [ read-= ] [ read-value ] tri
+ 2array ,
+ ] keep (parse-attributes)
] if ;
-: read-until-< ( -- string )
- [ get-char CHAR: < = ] take-until ;
-
-: parse-text ( -- )
- read-until-< [
- make-text-tag push-tag
- ] unless-empty ;
-
-: (parse-attributes) ( -- )
- read-whitespace*
- string-parse-end? [
- read-key >lower read-= read-value
- 2array , (parse-attributes)
- ] unless ;
-
-: parse-attributes ( -- hashtable )
+: parse-attributes ( state-parser -- hashtable )
[ (parse-attributes) ] { } make >hashtable ;
: (parse-tag) ( string -- string' hashtable )
[
- read-token >lower
- parse-attributes
+ [ read-token >lower ] [ parse-attributes ] bi
] string-parse ;
-: parse-tag ( -- )
- read-< [
- (parse-tag) make-tag push-tag
- ] unless-empty ;
+: read-< ( state-parser -- string/f )
+ next dup get-char [
+ CHAR: ! = [ read-bang f ] [ read-tag ] if
+ ] [
+ drop f
+ ] if* ;
-: (parse-html) ( -- )
- get-next [
- parse-text
- parse-tag
- (parse-html)
- ] when ;
+: parse-tag ( state-parser -- )
+ read-< [ (parse-tag) make-tag push-tag ] unless-empty ;
+
+: (parse-html) ( state-parser -- )
+ dup get-next [
+ [ parse-text ] [ parse-tag ] [ (parse-html) ] tri
+ ] [ drop ] if ;
: tag-parse ( quot -- vector )
V{ } clone tagstack [ string-parse ] with-variable ; inline
diff --git a/extra/html/parser/utils/utils-tests.factor b/extra/html/parser/utils/utils-tests.factor
index 6d8e3bc05f..ec6780687d 100644
--- a/extra/html/parser/utils/utils-tests.factor
+++ b/extra/html/parser/utils/utils-tests.factor
@@ -1,20 +1,13 @@
USING: assocs combinators continuations hashtables
hashtables.private io kernel math
namespaces prettyprint quotations sequences splitting
-strings tools.test ;
-USING: html.parser.utils ;
+strings tools.test html.parser.utils quoting ;
IN: html.parser.utils.tests
[ "'Rome'" ] [ "Rome" single-quote ] unit-test
[ "\"Roma\"" ] [ "Roma" double-quote ] unit-test
[ "'Firenze'" ] [ "Firenze" quote ] unit-test
[ "\"Caesar's\"" ] [ "Caesar's" quote ] unit-test
-[ f ] [ "" quoted? ] unit-test
-[ t ] [ "''" quoted? ] unit-test
-[ t ] [ "\"\"" quoted? ] unit-test
-[ t ] [ "\"Circus Maximus\"" quoted? ] unit-test
-[ t ] [ "'Circus Maximus'" quoted? ] unit-test
-[ f ] [ "Circus Maximus" quoted? ] unit-test
[ "'Italy'" ] [ "Italy" ?quote ] unit-test
[ "'Italy'" ] [ "'Italy'" ?quote ] unit-test
[ "\"Italy\"" ] [ "\"Italy\"" ?quote ] unit-test
diff --git a/extra/html/parser/utils/utils.factor b/extra/html/parser/utils/utils.factor
index c913b9d306..7abd2fcdf7 100644
--- a/extra/html/parser/utils/utils.factor
+++ b/extra/html/parser/utils/utils.factor
@@ -3,16 +3,12 @@
USING: assocs circular combinators continuations hashtables
hashtables.private io kernel math namespaces prettyprint
quotations sequences splitting html.parser.state strings
-combinators.short-circuit ;
+combinators.short-circuit quoting ;
IN: html.parser.utils
-: string-parse-end? ( -- ? ) get-next not ;
-
: trim1 ( seq ch -- newseq )
[ [ ?head-slice drop ] [ ?tail-slice drop ] bi ] 2keep drop like ;
-: quote? ( ch -- ? ) "'\"" member? ;
-
: single-quote ( str -- newstr ) "'" dup surround ;
: double-quote ( str -- newstr ) "\"" dup surround ;
@@ -21,14 +17,4 @@ IN: html.parser.utils
CHAR: ' over member?
[ double-quote ] [ single-quote ] if ;
-: quoted? ( str -- ? )
- {
- [ length 1 > ]
- [ first quote? ]
- [ [ first ] [ peek ] bi = ]
- } 1&& ;
-
: ?quote ( str -- newstr ) dup quoted? [ quote ] unless ;
-
-: unquote ( str -- newstr )
- dup quoted? [ but-last-slice rest-slice >string ] when ;
From ce04d1dfa96f0cfaf37155b8b8095c8122a172c0 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Tue, 31 Mar 2009 18:21:15 -0500
Subject: [PATCH 26/42] redo spider without dynamic variables
---
extra/spider/spider-docs.factor | 5 --
extra/spider/spider.factor | 114 ++++++++++++++++++++------------
2 files changed, 73 insertions(+), 46 deletions(-)
diff --git a/extra/spider/spider-docs.factor b/extra/spider/spider-docs.factor
index cdbd5e7e09..4ed00d39f6 100644
--- a/extra/spider/spider-docs.factor
+++ b/extra/spider/spider-docs.factor
@@ -16,11 +16,6 @@ HELP: run-spider
{ "spider" spider } }
{ $description "Runs a spider until completion. See the " { $subsection "spider-tutorial" } " for a complete description of the tuple slots that affect how thet spider works." } ;
-HELP: slurp-heap-while
-{ $values
- { "heap" "a heap" } { "quot1" quotation } { "quot2" quotation } }
-{ $description "Removes values from a heap that match the predicate quotation " { $snippet "quot1" } " and processes them with " { $snippet "quot2" } " until the predicate quotation no longer matches." } ;
-
ARTICLE: "spider-tutorial" "Spider tutorial"
"To create a new spider, call the " { $link <spider> } " word with a link to the site you wish to spider."
{ $code <" "http://concatenative.org" <spider> "> }
diff --git a/extra/spider/spider.factor b/extra/spider/spider.factor
index bd5b2668be..42f2485ebe 100644
--- a/extra/spider/spider.factor
+++ b/extra/spider/spider.factor
@@ -3,22 +3,44 @@
USING: accessors fry html.parser html.parser.analyzer
http.client kernel tools.time sets assocs sequences
concurrency.combinators io threads namespaces math multiline
-heaps math.parser inspector urls assoc-heaps logging
-combinators.short-circuit continuations calendar prettyprint ;
+math.parser inspector urls logging combinators.short-circuit
+continuations calendar prettyprint dlists deques locals ;
IN: spider
TUPLE: spider base count max-count sleep max-depth initial-links
-filters spidered todo nonmatching quiet ;
+filters spidered todo nonmatching filtered quiet ;
TUPLE: spider-result url depth headers fetch-time parsed-html
links processing-time timestamp ;
+TUPLE: todo-url url depth ;
+
+: <todo-url> ( url depth -- todo-url )
+ todo-url new
+ swap >>depth
+ swap >>url ;
+
+TUPLE: unique-deque assoc deque ;
+
+: <unique-deque> ( -- unique-deque )
+ H{ } clone <dlist> unique-deque boa ;
+
+: store-url ( url depth unique-deque -- )
+ [ <todo-url> ] dip
+ [ [ [ t ] dip url>> ] [ assoc>> ] bi* set-at ]
+ [ deque>> push-back ] 2bi ;
+
+: pop-url ( unique-deque -- todo-url ) deque>> pop-front ;
+
+: peek-url ( unique-deque -- todo-url ) deque>> peek-front ;
+
: <spider> ( base -- spider )
>url
spider new
over >>base
- swap 0 <unique-min-heap> [ heap-push ] keep >>todo
- <unique-min-heap> >>nonmatching
+ swap 0 <unique-deque> [ store-url ] keep >>todo
+ <unique-deque> >>nonmatching
+ <unique-deque> >>filtered
0 >>max-depth
0 >>count
1/0. >>max-count
@@ -27,10 +49,10 @@ links processing-time timestamp ;
<PRIVATE
: apply-filters ( links spider -- links' )
- filters>> [ '[ _ 1&& ] filter ] when* ;
+ filters>> [ '[ [ _ 1&& ] filter ] call( seq -- seq' ) ] when* ;
-: push-links ( links level assoc-heap -- )
- '[ _ _ heap-push ] each ;
+: push-links ( links level unique-deque -- )
+ '[ _ _ store-url ] each ;
: add-todo ( links level spider -- )
todo>> push-links ;
@@ -38,64 +60,74 @@ links processing-time timestamp ;
: add-nonmatching ( links level spider -- )
nonmatching>> push-links ;
-: filter-base ( spider spider-result -- base-links nonmatching-links )
+: add-filtered ( links level spider -- )
+ filtered>> push-links ;
+
+: filter-base-links ( spider spider-result -- base-links nonmatching-links )
[ base>> host>> ] [ links>> prune ] bi*
[ host>> = ] with partition ;
: add-spidered ( spider spider-result -- )
[ [ 1+ ] change-count ] dip
2dup [ spidered>> ] [ dup url>> ] bi* rot set-at
- [ filter-base ] 2keep
+ [ filter-base-links ] 2keep
depth>> 1+ swap
[ add-nonmatching ]
[ tuck [ apply-filters ] 2dip add-todo ] 2bi ;
-: normalize-hrefs ( links -- links' )
- [ >url ] map
- spider get base>> swap [ derive-url ] with map ;
+: normalize-hrefs ( links spider -- links' )
+ [ [ >url ] map ] dip
+ base>> swap [ derive-url ] with map ;
: print-spidering ( url depth -- )
"depth: " write number>string write
", spidering: " write . yield ;
-: (spider-page) ( url depth -- spider-result )
- f pick spider get spidered>> set-at
- over '[ _ http-get ] benchmark swap
- [ parse-html dup find-hrefs normalize-hrefs ] benchmark
+:: new-spidered-result ( spider url depth -- spider-result )
+ f url spider spidered>> set-at
+ [ url http-get ] benchmark :> fetch-time :> html :> headers
+ [
+ html parse-html [ ] [ find-hrefs spider normalize-hrefs ] bi
+ ] benchmark :> processing-time :> links :> parsed-html
+ url depth headers fetch-time parsed-html links processing-time
now spider-result boa ;
-: spider-page ( url depth -- )
- spider get quiet>> [ 2dup print-spidering ] unless
- (spider-page)
- spider get [ quiet>> [ dup describe ] unless ]
- [ swap add-spidered ] bi ;
+:: spider-page ( spider url depth -- )
+ spider quiet>> [ url depth print-spidering ] unless
+ spider url depth new-spidered-result :> spidered-result
+ spider quiet>> [ spidered-result describe ] unless
+ spider spidered-result add-spidered ;
\ spider-page ERROR add-error-logging
-: spider-sleep ( -- )
- spider get sleep>> [ sleep ] when* ;
+: spider-sleep ( spider -- )
+ sleep>> [ sleep ] when* ;
-: queue-initial-links ( spider -- spider )
- [ initial-links>> normalize-hrefs 0 ] keep
- [ add-todo ] keep ;
+:: queue-initial-links ( spider -- spider )
+ spider initial-links>> spider normalize-hrefs 0 spider add-todo spider ;
-: slurp-heap-while ( heap quot1 quot2: ( value key -- ) -- )
- pick heap-empty? [ 3drop ] [
- [ [ heap-pop dup ] 2dip slip [ t ] compose [ 2drop f ] if ]
- [ roll [ slurp-heap-while ] [ 3drop ] if ] 3bi
- ] if ; inline recursive
+: spider-page? ( spider -- ? )
+ {
+ [ todo>> deque>> deque-empty? not ]
+ [ [ todo>> peek-url depth>> ] [ max-depth>> ] bi < ]
+ } 1&& ;
+
+: setup-next-url ( spider -- spider url depth )
+ dup todo>> pop-url [ url>> ] [ depth>> ] bi ;
+
+: spider-next-page ( spider -- )
+ setup-next-url spider-page ;
PRIVATE>
+: run-spider-loop ( spider -- )
+ dup spider-page? [
+ [ spider-next-page ] [ run-spider-loop ] bi
+ ] [
+ drop
+ ] if ;
+
: run-spider ( spider -- spider )
"spider" [
- dup spider [
- queue-initial-links
- [ todo>> ] [ max-depth>> ] bi
- '[
- _ <= spider get
- [ count>> ] [ max-count>> ] bi < and
- ] [ spider-page spider-sleep ] slurp-heap-while
- spider get
- ] with-variable
+ queue-initial-links [ run-spider-loop ] keep
] with-logging ;
From e22823f2c44ba8769664178b66c2ea9f69d73705 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Tue, 31 Mar 2009 18:23:02 -0500
Subject: [PATCH 27/42] rename word
---
extra/spider/spider.factor | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/extra/spider/spider.factor b/extra/spider/spider.factor
index 42f2485ebe..0287d50692 100644
--- a/extra/spider/spider.factor
+++ b/extra/spider/spider.factor
@@ -25,7 +25,7 @@ TUPLE: unique-deque assoc deque ;
: <unique-deque> ( -- unique-deque )
H{ } clone <dlist> unique-deque boa ;
-: store-url ( url depth unique-deque -- )
+: push-url ( url depth unique-deque -- )
[ <todo-url> ] dip
[ [ [ t ] dip url>> ] [ assoc>> ] bi* set-at ]
[ deque>> push-back ] 2bi ;
@@ -38,7 +38,7 @@ TUPLE: unique-deque assoc deque ;
>url
spider new
over >>base
- swap 0 <unique-deque> [ store-url ] keep >>todo
+ swap 0 <unique-deque> [ push-url ] keep >>todo
<unique-deque> >>nonmatching
<unique-deque> >>filtered
0 >>max-depth
@@ -52,7 +52,7 @@ TUPLE: unique-deque assoc deque ;
filters>> [ '[ [ _ 1&& ] filter ] call( seq -- seq' ) ] when* ;
: push-links ( links level unique-deque -- )
- '[ _ _ store-url ] each ;
+ '[ _ _ push-url ] each ;
: add-todo ( links level spider -- )
todo>> push-links ;
From 8e26b19cc0aa008af012af16f2f1055a10faa251 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Tue, 31 Mar 2009 18:49:41 -0500
Subject: [PATCH 28/42] state-parser works with sequences, not strings fix bug
with take-until
---
extra/html/parser/parser.factor | 10 ++---
extra/html/parser/state/state-tests.factor | 20 +++++----
extra/html/parser/state/state.factor | 47 ++++++++++++----------
3 files changed, 44 insertions(+), 33 deletions(-)
diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor
index 677737618b..94ef59bdfd 100644
--- a/extra/html/parser/parser.factor
+++ b/extra/html/parser/parser.factor
@@ -68,10 +68,10 @@ SYMBOL: tagstack
[ blank? ] trim ;
: read-comment ( state-parser -- )
- "-->" take-until-string make-comment-tag push-tag ;
+ "-->" take-until-sequence make-comment-tag push-tag ;
: read-dtd ( state-parser -- )
- ">" take-until-string make-dtd-tag push-tag ;
+ ">" take-until-sequence make-dtd-tag push-tag ;
: read-bang ( state-parser -- )
next dup { [ get-char CHAR: - = ] [ get-next CHAR: - = ] } 1&& [
@@ -93,7 +93,7 @@ SYMBOL: tagstack
: (parse-attributes) ( state-parser -- )
skip-whitespace
- dup string-parse-end? [
+ dup state-parse-end? [
drop
] [
[
@@ -108,7 +108,7 @@ SYMBOL: tagstack
: (parse-tag) ( string -- string' hashtable )
[
[ read-token >lower ] [ parse-attributes ] bi
- ] string-parse ;
+ ] state-parse ;
: read-< ( state-parser -- string/f )
next dup get-char [
@@ -126,7 +126,7 @@ SYMBOL: tagstack
] [ drop ] if ;
: tag-parse ( quot -- vector )
- V{ } clone tagstack [ string-parse ] with-variable ; inline
+ V{ } clone tagstack [ state-parse ] with-variable ; inline
: parse-html ( string -- vector )
[ (parse-html) tagstack get ] tag-parse ;
diff --git a/extra/html/parser/state/state-tests.factor b/extra/html/parser/state/state-tests.factor
index f676649aa8..f9862e1e69 100644
--- a/extra/html/parser/state/state-tests.factor
+++ b/extra/html/parser/state/state-tests.factor
@@ -2,29 +2,35 @@ USING: tools.test html.parser.state ascii kernel accessors ;
IN: html.parser.state.tests
[ "hello" ]
-[ "hello" [ take-rest ] string-parse ] unit-test
+[ "hello" [ take-rest ] state-parse ] unit-test
[ "hi" " how are you?" ]
[
"hi how are you?"
- [ [ [ blank? ] take-until ] [ take-rest ] bi ] string-parse
+ [ [ [ blank? ] take-until ] [ take-rest ] bi ] state-parse
] unit-test
[ "foo" ";bar" ]
[
"foo;bar" [
- [ CHAR: ; take-until-char ] [ take-rest ] bi
- ] string-parse
+ [ CHAR: ; take-until-object ] [ take-rest ] bi
+ ] state-parse
] unit-test
[ "foo " " bar" ]
[
"foo and bar" [
- [ "and" take-until-string ] [ take-rest ] bi
- ] string-parse
+ [ "and" take-until-sequence ] [ take-rest ] bi
+ ] state-parse
] unit-test
[ 6 ]
[
- " foo " [ skip-whitespace i>> ] string-parse
+ " foo " [ skip-whitespace n>> ] state-parse
] unit-test
+
+[ { 1 2 } ]
+[ { 1 2 3 } <state-parser> [ 3 = ] take-until ] unit-test
+
+[ { 1 2 } ]
+[ { 1 2 3 4 } <state-parser> { 3 4 } take-until-sequence ] unit-test
diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor
index c69fd76af5..2369b1d750 100644
--- a/extra/html/parser/state/state.factor
+++ b/extra/html/parser/state/state.factor
@@ -2,31 +2,32 @@
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces math kernel sequences accessors fry circular
unicode.case unicode.categories locals ;
+
IN: html.parser.state
-TUPLE: state-parser string i ;
+TUPLE: state-parser sequence n ;
-: <state-parser> ( string -- state-parser )
+: <state-parser> ( sequence -- state-parser )
state-parser new
- swap >>string
- 0 >>i ;
+ swap >>sequence
+ 0 >>n ;
-: (get-char) ( i state -- char/f )
- string>> ?nth ; inline
+: (get-char) ( n state -- char/f )
+ sequence>> ?nth ; inline
: get-char ( state -- char/f )
- [ i>> ] keep (get-char) ; inline
+ [ n>> ] keep (get-char) ; inline
: get-next ( state -- char/f )
- [ i>> 1+ ] keep (get-char) ; inline
+ [ n>> 1 + ] keep (get-char) ; inline
: next ( state -- state )
- [ 1+ ] change-i ; inline
+ [ 1 + ] change-n ; inline
: get+increment ( state -- char/f )
[ get-char ] [ next drop ] bi ; inline
-: string-parse ( string quot -- )
+: state-parse ( sequence quot -- )
[ <state-parser> ] dip call ; inline
:: skip-until ( state quot: ( obj -- ? ) -- )
@@ -34,17 +35,23 @@ TUPLE: state-parser string i ;
quot call [ state next quot skip-until ] unless
] when* ; inline recursive
-: take-until ( state quot: ( obj -- ? ) -- string )
- [ drop i>> ]
- [ skip-until ]
- [ drop [ i>> ] [ string>> ] bi ] 2tri subseq ; inline
+: state-parse-end? ( state -- ? ) get-next not ;
-:: take-until-string ( state-parser string -- string' )
- string length <growing-circular> :> growing
+: take-until ( state quot: ( obj -- ? ) -- sequence/f )
+ over state-parse-end? [
+ 2drop f
+ ] [
+ [ drop n>> ]
+ [ skip-until ]
+ [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq
+ ] if ; inline
+
+:: take-until-sequence ( state-parser sequence -- sequence' )
+ sequence length <growing-circular> :> growing
state-parser
[
growing push-growing-circular
- string growing sequence=
+ sequence growing sequence=
] take-until :> found
found dup length
growing length 1- - head
@@ -53,10 +60,8 @@ TUPLE: state-parser string i ;
: skip-whitespace ( state -- state )
[ [ blank? not ] take-until drop ] keep ;
-: take-rest ( state -- string )
+: take-rest ( state -- sequence )
[ drop f ] take-until ; inline
-: take-until-char ( state ch -- string )
+: take-until-object ( state obj -- sequence )
'[ _ = ] take-until ;
-
-: string-parse-end? ( state -- ? ) get-next not ;
From 15cb926afb6504bb24095f2788df3fdf0d2612ba Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 31 Mar 2009 21:23:09 -0500
Subject: [PATCH 29/42] smalltalk: Working on message cascade syntax
---
extra/smalltalk/ast/ast.factor | 11 ++-
extra/smalltalk/compiler/compiler.factor | 52 ++++++++++++--
extra/smalltalk/compiler/lexenv/lexenv.factor | 4 +-
extra/smalltalk/eval/authors.txt | 1 +
extra/smalltalk/eval/eval-tests.factor | 5 ++
extra/smalltalk/eval/eval.factor | 8 +++
extra/smalltalk/library/library.factor | 13 ++--
extra/smalltalk/listener/listener.factor | 14 ++--
extra/smalltalk/parser/parser-tests.factor | 68 +++++++++++++++++--
extra/smalltalk/parser/parser.factor | 67 ++++++++++--------
extra/smalltalk/parser/test.st | 4 +-
11 files changed, 194 insertions(+), 53 deletions(-)
create mode 100644 extra/smalltalk/eval/authors.txt
create mode 100644 extra/smalltalk/eval/eval-tests.factor
create mode 100644 extra/smalltalk/eval/eval.factor
diff --git a/extra/smalltalk/ast/ast.factor b/extra/smalltalk/ast/ast.factor
index f426789316..69bfc3dbf6 100644
--- a/extra/smalltalk/ast/ast.factor
+++ b/extra/smalltalk/ast/ast.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: strings arrays memoize kernel ;
+USING: strings arrays memoize kernel sequences accessors ;
IN: smalltalk.ast
SINGLETONS: nil self super ;
@@ -8,6 +8,8 @@ SINGLETONS: nil self super ;
TUPLE: ast-comment { string string } ;
TUPLE: ast-block { arguments array } { body array } ;
TUPLE: ast-message-send receiver { selector string } { arguments array } ;
+TUPLE: ast-message { selector string } { arguments array } ;
+TUPLE: ast-cascade receiver { messages array } ;
TUPLE: ast-name { name string } ;
TUPLE: ast-return value ;
TUPLE: ast-assignment { name ast-name } value ;
@@ -15,6 +17,13 @@ TUPLE: ast-local-variables { names array } ;
TUPLE: ast-method { name string } { body ast-block } ;
TUPLE: ast-class { name string } { superclass string } { ivars array } { methods array } ;
TUPLE: ast-foreign { class string } { name string } ;
+TUPLE: ast-sequence { statements array } ;
+
+: <ast-cascade> ( receiver messages -- ast )
+ dup length 1 =
+ [ first [ selector>> ] [ arguments>> ] bi ast-message-send boa ]
+ [ ast-cascade boa ]
+ if ;
TUPLE: symbol { name string } ;
MEMO: intern ( name -- symbol ) symbol boa ;
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor
index 9c3638ba6c..4a2417e91d 100644
--- a/extra/smalltalk/compiler/compiler.factor
+++ b/extra/smalltalk/compiler/compiler.factor
@@ -3,7 +3,7 @@
USING: accessors arrays assocs combinators.short-circuit
continuations fry kernel namespaces quotations sequences sets
generalizations slots locals.types generalizations splitting math
-locals.rewrite.closures generic words smalltalk.ast
+locals.rewrite.closures generic words combinators smalltalk.ast
smalltalk.compiler.lexenv smalltalk.selectors
smalltalk.classes ;
IN: smalltalk.compiler
@@ -22,9 +22,21 @@ M: ast-message-send need-return-continuation?
[ arguments>> need-return-continuation? ]
} 1&& ;
+M: ast-cascade need-return-continuation?
+ {
+ [ receiver>> need-return-continuation? ]
+ [ messages>> need-return-continuation? ]
+ } 1&& ;
+
+M: ast-message need-return-continuation?
+ arguments>> need-return-continuation? ;
+
M: ast-assignment need-return-continuation?
value>> need-return-continuation? ;
+M: ast-sequence need-return-continuation?
+ statements>> need-return-continuation? ;
+
M: array need-return-continuation? [ need-return-continuation? ] any? ;
M: object need-return-continuation? drop f ;
@@ -37,14 +49,25 @@ M: ast-block assigned-locals
[ body>> assigned-locals ] [ arguments>> ] bi diff ;
M: ast-message-send assigned-locals
- [ arguments>> assigned-locals ]
[ receiver>> assigned-locals ]
+ [ arguments>> assigned-locals ]
bi append ;
+M: ast-cascade assigned-locals
+ [ arguments>> assigned-locals ]
+ [ messages>> assigned-locals ]
+ bi append ;
+
+M: ast-message assigned-locals
+ arguments>> assigned-locals ;
+
M: ast-assignment assigned-locals
[ name>> dup ast-name? [ name>> 1array ] [ drop { } ] if ]
[ value>> assigned-locals ] bi append ;
+M: ast-sequence assigned-locals
+ statements>> assigned-locals ;
+
M: array assigned-locals
[ assigned-locals ] map concat ;
@@ -60,16 +83,37 @@ ERROR: unbound-local name ;
M: ast-name compile-ast name>> swap lookup-reader ;
+: compile-arguments ( lexenv ast -- quot )
+ arguments>> [ compile-ast ] with map [ ] join ;
+
M: ast-message-send compile-ast
- [ arguments>> [ compile-ast ] with map [ ] join ]
+ [ compile-arguments ]
[ receiver>> compile-ast ]
[ nip selector>> selector>generic ]
2tri [ append ] dip suffix ;
+M: ast-cascade compile-ast
+ [ receiver>> compile-ast ]
+ [
+ messages>> [
+ [ compile-arguments \ dip ]
+ [ selector>> selector>generic ] bi
+ [ ] 3sequence
+ ] with map
+ unclip-last [ [ [ drop ] append ] map ] dip suffix
+ cleave>quot
+ ] 2bi append ;
+
M: ast-return compile-ast
value>> compile-ast
[ return-continuation get continue-with ] append ;
+: compile-sequence ( lexenv asts -- quot )
+ [ drop [ nil ] ] [ [ compile-ast ] with map [ drop ] join ] if-empty ;
+
+M: ast-sequence compile-ast
+ statements>> compile-sequence ;
+
GENERIC: contains-blocks? ( obj -- ? )
M: ast-block contains-blocks? drop t ;
@@ -110,7 +154,7 @@ M: ast-assignment compile-ast
[ nip local-readers>> values ]
[ lexenv-union ] 2bi
] [ body>> ] bi
- [ drop [ nil ] ] [ [ compile-ast ] with map [ drop ] join ] if-empty ;
+ compile-sequence ;
M: ast-block compile-ast
compile-block <lambda> '[ _ ] ;
diff --git a/extra/smalltalk/compiler/lexenv/lexenv.factor b/extra/smalltalk/compiler/lexenv/lexenv.factor
index b204b057b6..6b6d283761 100644
--- a/extra/smalltalk/compiler/lexenv/lexenv.factor
+++ b/extra/smalltalk/compiler/lexenv/lexenv.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel accessors quotations slots words
sequences namespaces combinators combinators.short-circuit
-smalltalk.classes ;
+summary smalltalk.classes ;
IN: smalltalk.compiler.lexenv
! local-readers: assoc string => word
@@ -39,6 +39,8 @@ CONSTANT: empty-lexenv T{ lexenv }
ERROR: bad-identifier name ;
+M: bad-identifier summary drop "Unknown identifier" ;
+
: lookup-reader ( name lexenv -- reader-quot )
{
[ local-reader ]
diff --git a/extra/smalltalk/eval/authors.txt b/extra/smalltalk/eval/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/eval/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/eval/eval-tests.factor b/extra/smalltalk/eval/eval-tests.factor
new file mode 100644
index 0000000000..33f28a2bd8
--- /dev/null
+++ b/extra/smalltalk/eval/eval-tests.factor
@@ -0,0 +1,5 @@
+IN: smalltalk.eval.tests
+USING: smalltalk.eval tools.test ;
+
+[ 3 ] [ "1+2" eval-smalltalk ] unit-test
+[ "HAI" ] [ "(1<10) ifTrue:['HAI'] ifFalse:['BAI']" eval-smalltalk ] unit-test
\ No newline at end of file
diff --git a/extra/smalltalk/eval/eval.factor b/extra/smalltalk/eval/eval.factor
new file mode 100644
index 0000000000..60f0d9cce2
--- /dev/null
+++ b/extra/smalltalk/eval/eval.factor
@@ -0,0 +1,8 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: compiler.units smalltalk.parser smalltalk.compiler ;
+IN: smalltalk.eval
+
+: eval-smalltalk ( string -- result )
+ [ parse-smalltalk compile-smalltalk ] with-compilation-unit
+ call( -- result ) ;
\ No newline at end of file
diff --git a/extra/smalltalk/library/library.factor b/extra/smalltalk/library/library.factor
index 1b24db71e8..1a8cb8d177 100644
--- a/extra/smalltalk/library/library.factor
+++ b/extra/smalltalk/library/library.factor
@@ -1,17 +1,15 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel present io math sequences assocs math.ranges
-locals smalltalk.selectors smalltalk.ast smalltalk.classes ;
+USING: kernel present io math sequences assocs math.ranges fry
+tools.time locals smalltalk.selectors smalltalk.ast smalltalk.classes ;
IN: smalltalk.library
-! Some unary selectors
SELECTOR: print
SELECTOR: asString
M: object selector-print dup present print ;
M: object selector-asString present ;
-! Some binary selectors
SELECTOR: +
SELECTOR: -
SELECTOR: *
@@ -32,7 +30,6 @@ M: object selector-<= swap <= ;
M: object selector->= swap >= ;
M: object selector-= swap = ;
-! Some keyword selectors
SELECTOR: ifTrue:
SELECTOR: ifFalse:
SELECTOR: ifTrue:ifFalse:
@@ -76,4 +73,8 @@ M: object selector-value:value:value:value: call( input input input input -- res
SELECTOR: new
-M: object selector-new new ;
\ No newline at end of file
+M: object selector-new new ;
+
+SELECTOR: time
+
+M: object selector-time '[ _ call( -- result ) ] time ;
\ No newline at end of file
diff --git a/extra/smalltalk/listener/listener.factor b/extra/smalltalk/listener/listener.factor
index bef4adc196..e052f0c629 100644
--- a/extra/smalltalk/listener/listener.factor
+++ b/extra/smalltalk/listener/listener.factor
@@ -2,17 +2,17 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel prettyprint io io.styles colors.constants compiler.units
fry debugger sequences locals.rewrite.closures smalltalk.ast
-smalltalk.parser smalltalk.compiler smalltalk.printer ;
+smalltalk.eval smalltalk.printer ;
IN: smalltalk.listener
-: eval-smalltalk ( string -- )
- [
- parse-smalltalk compile-smalltalk
- ] with-compilation-unit call( -- result )
- dup nil? [ drop ] [ "Result: " write smalltalk>string print ] if ;
+: eval-interactively ( string -- )
+ '[
+ _ eval-smalltalk
+ dup nil? [ drop ] [ "Result: " write smalltalk>string print ] if
+ ] try ;
: smalltalk-listener ( -- )
"Smalltalk>" { { background COLOR: light-blue } } format bl flush readln
- [ '[ _ eval-smalltalk ] try smalltalk-listener ] when* ;
+ [ eval-interactively smalltalk-listener ] when* ;
MAIN: smalltalk-listener
\ No newline at end of file
diff --git a/extra/smalltalk/parser/parser-tests.factor b/extra/smalltalk/parser/parser-tests.factor
index aa440f581e..1ed6108376 100644
--- a/extra/smalltalk/parser/parser-tests.factor
+++ b/extra/smalltalk/parser/parser-tests.factor
@@ -164,6 +164,41 @@ test = <foreign parse-smalltalk Expression>
]
[ "((1 < 10) ifTrue: [ 'HI' ] ifFalse: [ 'BYE' ]) print" test-Expression ] unit-test
+[
+ T{ ast-cascade
+ { receiver 12 }
+ { messages
+ {
+ T{ ast-message f "sqrt" }
+ T{ ast-message f "+" { 2 } }
+ }
+ }
+ }
+]
+[ "12 sqrt; + 2" test-Expression ] unit-test
+
+[
+ T{ ast-cascade
+ { receiver T{ ast-message-send f 12 "sqrt" } }
+ { messages
+ {
+ T{ ast-message f "+" { 1 } }
+ T{ ast-message f "+" { 2 } }
+ }
+ }
+ }
+]
+[ "12 sqrt + 1; + 2" test-Expression ] unit-test
+
+[
+ T{ ast-message-send f
+ T{ ast-message-send f 1 "+" { 2 } }
+ "*"
+ { 3 }
+ }
+]
+[ "1+2*3" test-Expression ] unit-test
+
[
T{ ast-message-send
{ receiver
@@ -214,15 +249,38 @@ test = <foreign parse-smalltalk KeywordMessageSend>
]
[ "3 factorial + 4 factorial between: 10 and: 100" test-KeywordMessageSend ] unit-test
-[ { 1 2 } ] [ "1. 2" parse-smalltalk ] unit-test
+[ T{ ast-sequence f { 1 2 } } ] [ "1. 2" parse-smalltalk ] unit-test
[
- T{ ast-class
- { name "Test" }
- { superclass "Object" }
- { ivars { "a" } }
+ T{ ast-sequence f
+ {
+ T{ ast-class
+ { name "Test" }
+ { superclass "Object" }
+ { ivars { "a" } }
+ }
+ }
}
]
[ "class Test [|a|]" parse-smalltalk ] unit-test
+[
+ T{ ast-sequence f
+ {
+ T{ ast-class
+ { name "Test1" }
+ { superclass "Object" }
+ { ivars { "a" } }
+ }
+
+ T{ ast-class
+ { name "Test2" }
+ { superclass "Test1" }
+ { ivars { "b" } }
+ }
+ }
+ }
+]
+[ "class Test1 [|a|]. class Test2 extends Test1 [|b|]" parse-smalltalk ] unit-test
+
[ ] [ "vocab:smalltalk/parser/test.st" ascii file-contents parse-smalltalk drop ] unit-test
diff --git a/extra/smalltalk/parser/parser.factor b/extra/smalltalk/parser/parser.factor
index e153e1552d..d6194a9637 100644
--- a/extra/smalltalk/parser/parser.factor
+++ b/extra/smalltalk/parser/parser.factor
@@ -4,6 +4,8 @@ USING: peg peg.ebnf smalltalk.ast sequences sequences.deep strings
math.parser kernel arrays byte-arrays math assocs accessors ;
IN: smalltalk.parser
+! :mode=text:noTabs=true:
+
! Based on http://chronos-st.blogspot.com/2007/12/smalltalk-in-one-page.html
ERROR: bad-number str ;
@@ -120,43 +122,52 @@ Operand = Literal
| Reference
| NestedExpression
-UnaryMessage = UnaryMessageSelector
+UnaryMessage = OptionalWhiteSpace
+ UnaryMessageSelector:s !(":")
+ => [[ s { } ast-message boa ]]
UnaryMessageOperand = UnaryMessageSend | Operand
UnaryMessageSend = UnaryMessageOperand:receiver
- OptionalWhiteSpace UnaryMessageSelector:selector !(":")
- => [[ receiver selector { } ast-message-send boa ]]
+ UnaryMessage:h
+ (OptionalWhiteSpace ";" UnaryMessage:m => [[ m ]])*:t
+ => [[ receiver t h prefix >array <ast-cascade> ]]
-BinaryMessage = BinaryMessageSelector OptionalWhiteSpace BinaryMessageOperand
+BinaryMessage = OptionalWhiteSpace
+ BinaryMessageSelector:selector
+ OptionalWhiteSpace
+ BinaryMessageOperand:rhs
+ => [[ selector { rhs } ast-message boa ]]
+
BinaryMessageOperand = BinaryMessageSend | UnaryMessageSend | Operand
-BinaryMessageSend-1 = BinaryMessageOperand:lhs
- OptionalWhiteSpace
- BinaryMessageSelector:selector
- OptionalWhiteSpace
- UnaryMessageOperand:rhs
- => [[ lhs selector { rhs } ast-message-send boa ]]
-BinaryMessageSend = (BinaryMessageSend:lhs
- OptionalWhiteSpace
- BinaryMessageSelector:selector
- OptionalWhiteSpace
- UnaryMessageOperand:rhs
- => [[ lhs selector { rhs } ast-message-send boa ]])
- | BinaryMessageSend-1
+BinaryMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):lhs
+ BinaryMessage:h
+ (OptionalWhiteSpace ";" BinaryMessage:m => [[ m ]])*:t
+ => [[ lhs t h prefix >array <ast-cascade> ]]
KeywordMessageSegment = Keyword:k OptionalWhiteSpace BinaryMessageOperand:arg => [[ { k arg } ]]
+KeywordMessage = OptionalWhiteSpace
+ KeywordMessageSegment:h
+ (OptionalWhiteSpace KeywordMessageSegment:s => [[ s ]])*:t
+ => [[ t h prefix unzip [ concat ] dip ast-message boa ]]
KeywordMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):receiver
OptionalWhiteSpace
- KeywordMessageSegment:h
- (OptionalWhiteSpace KeywordMessageSegment:s => [[ s ]])*:t
- => [[ receiver t h prefix unzip [ concat ] dip ast-message-send boa ]]
+ KeywordMessage:m
+ => [[ receiver m 1array <ast-cascade> ]]
+
+Message = BinaryMessage | UnaryMessage | KeywordMessage
+
+MessageSend = (MessageSend | Operand):lhs
+ Message:h
+ (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t
+ => [[ lhs t h prefix >array <ast-cascade> ]]
Expression = OptionalWhiteSpace
- (KeywordMessageSend | BinaryMessageSend | UnaryMessageSend | Operand):e
+ (MessageSend | Operand):e
=> [[ e ]]
AssignmentOperation = OptionalWhiteSpace BindableIdentifier:i
OptionalWhiteSpace ":=" OptionalWhiteSpace => [[ i ast-name boa ]]
AssignmentStatement = AssignmentOperation:a Statement:s => [[ a s ast-assignment boa ]]
-Statement = AssignmentStatement | Expression
+Statement = ClassDeclaration | ForeignClassDeclaration | AssignmentStatement | Expression
MethodReturnOperator = OptionalWhiteSpace "^"
FinalStatement = (MethodReturnOperator Statement:s => [[ s ast-return boa ]])
@@ -168,10 +179,12 @@ LocalVariableDeclarationList = OptionalWhiteSpace "|" OptionalWhiteSpace
=> [[ t h prefix ]]
)?:b OptionalWhiteSpace "|" => [[ b >array ast-local-variables boa ]]
-ExecutableCode = (LocalVariableDeclarationList)?
- ((Statement:s OptionalWhiteSpace "." => [[ s ]])*
- FinalStatement:f (".")? => [[ f ]])?
- => [[ sift >array ]]
+ExecutableCode = (LocalVariableDeclarationList)?:locals
+ ((Statement:s OptionalWhiteSpace "." => [[ s ]])*:h
+ FinalStatement:t (".")? => [[ h t suffix ]])?:body
+ => [[ body locals [ suffix ] when* >array ]]
+
+TopLevelForm = ExecutableCode => [[ ast-sequence boa ]]
UnaryMethodHeader = UnaryMessageSelector:selector
=> [[ { selector { } } ]]
@@ -206,6 +219,6 @@ ForeignClassDeclaration = OptionalWhiteSpace "foreign"
=> [[ class name ast-foreign boa ]]
End = !(.)
-Program = (ClassDeclaration|ForeignClassDeclaration|ExecutableCode) => [[ nil or ]] End
+Program = TopLevelForm End
;EBNF
\ No newline at end of file
diff --git a/extra/smalltalk/parser/test.st b/extra/smalltalk/parser/test.st
index 7771ee2b9c..493d270f9b 100644
--- a/extra/smalltalk/parser/test.st
+++ b/extra/smalltalk/parser/test.st
@@ -32,7 +32,7 @@ class TreeNode extends Object [
nextPutAll: ' check: '; print: longLivedTree itemCheck; nl
]
- binarytrees [
+ method binarytrees [
self binarytrees: self arg to: self stdout.
^''
]
@@ -63,4 +63,4 @@ class TreeNode extends Object [
]
]
-Tests binarytrees.
+Tests binarytrees
From 95d9b3a417ef8e18fd3615dfb34880f680cb4213 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-122.local>
Date: Tue, 31 Mar 2009 21:48:43 -0500
Subject: [PATCH 30/42] Adding functionality to unicode breaks API for future
UI changes
---
basis/unicode/breaks/breaks-tests.factor | 3 +++
basis/unicode/breaks/breaks.factor | 14 ++++++++++----
2 files changed, 13 insertions(+), 4 deletions(-)
diff --git a/basis/unicode/breaks/breaks-tests.factor b/basis/unicode/breaks/breaks-tests.factor
index 493c2db0c2..3a26b01213 100644
--- a/basis/unicode/breaks/breaks-tests.factor
+++ b/basis/unicode/breaks/breaks-tests.factor
@@ -9,6 +9,9 @@ IN: unicode.breaks.tests
[ 3 ] [ "\u001112\u001161\u0011abA\u000300a"
dup last-grapheme head last-grapheme ] unit-test
+[ 3 ] [ 2 "hello" first-grapheme-from ] unit-test
+[ 1 ] [ 2 "hello" last-grapheme-from ] unit-test
+
: grapheme-break-test ( -- filename )
"vocab:unicode/breaks/GraphemeBreakTest.txt" ;
diff --git a/basis/unicode/breaks/breaks.factor b/basis/unicode/breaks/breaks.factor
index 12314505d9..1b1d9434f8 100644
--- a/basis/unicode/breaks/breaks.factor
+++ b/basis/unicode/breaks/breaks.factor
@@ -101,6 +101,16 @@ PRIVATE>
[ grapheme-class [ nip ] [ grapheme-break? ] 2bi ] find drop
nip swap length or 1+ ;
+: first-grapheme-from ( start str -- i )
+ over tail-slice first-grapheme + ;
+
+: last-grapheme ( str -- i )
+ unclip-last-slice grapheme-class swap
+ [ grapheme-class dup rot grapheme-break? ] find-last drop ?1+ nip ;
+
+: last-grapheme-from ( end str -- i )
+ swap head-slice last-grapheme ;
+
<PRIVATE
: >pieces ( str quot: ( str -- i ) -- graphemes )
@@ -114,10 +124,6 @@ PRIVATE>
: string-reverse ( str -- rts )
>graphemes reverse concat ;
-: last-grapheme ( str -- i )
- unclip-last-slice grapheme-class swap
- [ grapheme-class dup rot grapheme-break? ] find-last drop ?1+ nip ;
-
<PRIVATE
graphemes init-table table
From 3211270d5bc0c5900db88470b59ada4e9daee076 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-122.local>
Date: Tue, 31 Mar 2009 21:49:14 -0500
Subject: [PATCH 31/42] left and right arrow keys move between graphemes in UI
---
.../documents/elements/elements-tests.factor | 84 ++++++++++---------
basis/documents/elements/elements.factor | 32 +++----
2 files changed, 60 insertions(+), 56 deletions(-)
diff --git a/basis/documents/elements/elements-tests.factor b/basis/documents/elements/elements-tests.factor
index a3f05d7a71..9b323ae8e9 100644
--- a/basis/documents/elements/elements-tests.factor
+++ b/basis/documents/elements/elements-tests.factor
@@ -3,68 +3,72 @@
USING: tools.test namespaces documents documents.elements multiline ;
IN: document.elements.tests
-<document> "doc" set
-"123\nabc" "doc" get set-doc-string
+SYMBOL: doc
+<document> doc set
+"123\nabcé" doc get set-doc-string
! char-elt
-[ { 0 0 } ] [ { 0 0 } "doc" get char-elt prev-elt ] unit-test
-[ { 0 0 } ] [ { 0 1 } "doc" get char-elt prev-elt ] unit-test
-[ { 0 3 } ] [ { 1 0 } "doc" get char-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 0 } doc get char-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 1 } doc get char-elt prev-elt ] unit-test
+[ { 0 3 } ] [ { 1 0 } doc get char-elt prev-elt ] unit-test
+[ { 1 3 } ] [ { 1 5 } doc get char-elt prev-elt ] unit-test
-[ { 1 3 } ] [ { 1 3 } "doc" get char-elt next-elt ] unit-test
-[ { 0 2 } ] [ { 0 1 } "doc" get char-elt next-elt ] unit-test
-[ { 1 0 } ] [ { 0 3 } "doc" get char-elt next-elt ] unit-test
+[ { 1 5 } ] [ { 1 5 } doc get char-elt next-elt ] unit-test
+[ { 0 2 } ] [ { 0 1 } doc get char-elt next-elt ] unit-test
+[ { 1 0 } ] [ { 0 3 } doc get char-elt next-elt ] unit-test
+[ { 1 5 } ] [ { 1 3 } doc get char-elt next-elt ] unit-test
! word-elt
-<document> "doc" set
-"Hello world\nanother line" "doc" get set-doc-string
+<document> doc set
+"Hello world\nanother line" doc get set-doc-string
-[ { 0 0 } ] [ { 0 0 } "doc" get word-elt prev-elt ] unit-test
-[ { 0 0 } ] [ { 0 2 } "doc" get word-elt prev-elt ] unit-test
-[ { 0 0 } ] [ { 0 5 } "doc" get word-elt prev-elt ] unit-test
-[ { 0 5 } ] [ { 0 6 } "doc" get word-elt prev-elt ] unit-test
-[ { 0 6 } ] [ { 0 8 } "doc" get word-elt prev-elt ] unit-test
-[ { 0 11 } ] [ { 1 0 } "doc" get word-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 0 } doc get word-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 2 } doc get word-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 5 } doc get word-elt prev-elt ] unit-test
+[ { 0 5 } ] [ { 0 6 } doc get word-elt prev-elt ] unit-test
+[ { 0 6 } ] [ { 0 8 } doc get word-elt prev-elt ] unit-test
+[ { 0 11 } ] [ { 1 0 } doc get word-elt prev-elt ] unit-test
+
+[ { 0 5 } ] [ { 0 0 } doc get word-elt next-elt ] unit-test
+[ { 0 6 } ] [ { 0 5 } doc get word-elt next-elt ] unit-test
+[ { 0 11 } ] [ { 0 6 } doc get word-elt next-elt ] unit-test
+[ { 1 0 } ] [ { 0 11 } doc get word-elt next-elt ] unit-test
-[ { 0 5 } ] [ { 0 0 } "doc" get word-elt next-elt ] unit-test
-[ { 0 6 } ] [ { 0 5 } "doc" get word-elt next-elt ] unit-test
-[ { 0 11 } ] [ { 0 6 } "doc" get word-elt next-elt ] unit-test
-[ { 1 0 } ] [ { 0 11 } "doc" get word-elt next-elt ] unit-test
! one-word-elt
-[ { 0 0 } ] [ { 0 0 } "doc" get one-word-elt prev-elt ] unit-test
-[ { 0 0 } ] [ { 0 2 } "doc" get one-word-elt prev-elt ] unit-test
-[ { 0 0 } ] [ { 0 5 } "doc" get one-word-elt prev-elt ] unit-test
-[ { 0 5 } ] [ { 0 2 } "doc" get one-word-elt next-elt ] unit-test
-[ { 0 5 } ] [ { 0 5 } "doc" get one-word-elt next-elt ] unit-test
+[ { 0 0 } ] [ { 0 0 } doc get one-word-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 2 } doc get one-word-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 5 } doc get one-word-elt prev-elt ] unit-test
+[ { 0 5 } ] [ { 0 2 } doc get one-word-elt next-elt ] unit-test
+[ { 0 5 } ] [ { 0 5 } doc get one-word-elt next-elt ] unit-test
! line-elt
-<document> "doc" set
-"Hello\nworld, how are\nyou?" "doc" get set-doc-string
+<document> doc set
+"Hello\nworld, how are\nyou?" doc get set-doc-string
-[ { 0 0 } ] [ { 0 3 } "doc" get line-elt prev-elt ] unit-test
-[ { 0 3 } ] [ { 1 3 } "doc" get line-elt prev-elt ] unit-test
-[ { 2 4 } ] [ { 2 1 } "doc" get line-elt next-elt ] unit-test
+[ { 0 0 } ] [ { 0 3 } doc get line-elt prev-elt ] unit-test
+[ { 0 3 } ] [ { 1 3 } doc get line-elt prev-elt ] unit-test
+[ { 2 4 } ] [ { 2 1 } doc get line-elt next-elt ] unit-test
! one-line-elt
-[ { 1 0 } ] [ { 1 3 } "doc" get one-line-elt prev-elt ] unit-test
-[ { 1 14 } ] [ { 1 3 } "doc" get one-line-elt next-elt ] unit-test
+[ { 1 0 } ] [ { 1 3 } doc get one-line-elt prev-elt ] unit-test
+[ { 1 14 } ] [ { 1 3 } doc get one-line-elt next-elt ] unit-test
! page-elt
-<document> "doc" set
+<document> doc set
<" First line
Second line
Third line
Fourth line
Fifth line
-Sixth line"> "doc" get set-doc-string
+Sixth line"> doc get set-doc-string
-[ { 0 0 } ] [ { 3 3 } "doc" get 4 <page-elt> prev-elt ] unit-test
-[ { 1 2 } ] [ { 5 2 } "doc" get 4 <page-elt> prev-elt ] unit-test
+[ { 0 0 } ] [ { 3 3 } doc get 4 <page-elt> prev-elt ] unit-test
+[ { 1 2 } ] [ { 5 2 } doc get 4 <page-elt> prev-elt ] unit-test
-[ { 4 3 } ] [ { 0 3 } "doc" get 4 <page-elt> next-elt ] unit-test
-[ { 5 10 } ] [ { 4 2 } "doc" get 4 <page-elt> next-elt ] unit-test
+[ { 4 3 } ] [ { 0 3 } doc get 4 <page-elt> next-elt ] unit-test
+[ { 5 10 } ] [ { 4 2 } doc get 4 <page-elt> next-elt ] unit-test
! doc-elt
-[ { 0 0 } ] [ { 3 4 } "doc" get doc-elt prev-elt ] unit-test
-[ { 5 10 } ] [ { 3 4 } "doc" get doc-elt next-elt ] unit-test
\ No newline at end of file
+[ { 0 0 } ] [ { 3 4 } doc get doc-elt prev-elt ] unit-test
+[ { 5 10 } ] [ { 3 4 } doc get doc-elt next-elt ] unit-test
diff --git a/basis/documents/elements/elements.factor b/basis/documents/elements/elements.factor
index 9a8b82acac..f485f1bec1 100644
--- a/basis/documents/elements/elements.factor
+++ b/basis/documents/elements/elements.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators documents fry kernel math sequences
-accessors unicode.categories combinators.short-circuit ;
+accessors unicode.categories unicode.breaks combinators.short-circuit ;
IN: documents.elements
GENERIC: prev-elt ( loc document elt -- newloc )
@@ -27,20 +27,25 @@ SINGLETON: char-elt
[ call ]
} cond ; inline
-: next ( loc document quot: ( loc document -- loc )
+: next ( loc document quot: ( loc document -- loc ) -- loc )
{
{ [ 2over doc-end = ] [ 2drop ] }
{ [ 2over line-end? ] [ 2drop first 1+ 0 2array ] }
[ call ]
} cond ; inline
+: modify-col ( loc document quot: ( col str -- col' ) -- loc )
+ pick [
+ [ [ first2 swap ] dip doc-line ] dip call
+ ] dip =col ; inline
+
PRIVATE>
M: char-elt prev-elt
- drop [ drop -1 +col ] prev ;
+ drop [ [ last-grapheme-from ] modify-col ] prev ;
M: char-elt next-elt
- drop [ drop 1 +col ] next ;
+ drop [ [ first-grapheme-from ] modify-col ] next ;
SINGLETON: one-char-elt
@@ -50,22 +55,17 @@ M: one-char-elt next-elt 2drop ;
<PRIVATE
-: (word-elt) ( loc document quot -- loc )
- pick [
- [ [ first2 swap ] dip doc-line ] dip call
- ] dip =col ; inline
-
: blank-at? ( n seq -- n seq ? )
2dup ?nth blank? ;
: break-detector ( ? -- quot )
'[ blank? _ xor ] ; inline
-: (prev-word) ( col str ? -- col )
+: prev-word ( col str ? -- col )
break-detector find-last-from drop ?1+ ;
-: (next-word) ( col str ? -- col )
- { [ break-detector find-from drop ] [ drop length ] } 2|| ;
+: next-word ( col str ? -- col )
+ [ break-detector find-from drop ] [ drop length ] 2bi or ;
PRIVATE>
@@ -73,22 +73,22 @@ SINGLETON: one-word-elt
M: one-word-elt prev-elt
drop
- [ [ 1- ] dip f (prev-word) ] (word-elt) ;
+ [ [ 1- ] dip f prev-word ] modify-col ;
M: one-word-elt next-elt
drop
- [ f (next-word) ] (word-elt) ;
+ [ f next-word ] modify-col ;
SINGLETON: word-elt
M: word-elt prev-elt
drop
- [ [ [ 1- ] dip blank-at? (prev-word) ] (word-elt) ]
+ [ [ [ 1- ] dip blank-at? prev-word ] modify-col ]
prev ;
M: word-elt next-elt
drop
- [ [ blank-at? (next-word) ] (word-elt) ]
+ [ [ blank-at? next-word ] modify-col ]
next ;
SINGLETON: one-line-elt
From d0921b1d2d9b7b965c7a47e09e11aed79de1ddd6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 31 Mar 2009 22:30:13 -0500
Subject: [PATCH 32/42] Smalltalk parser work in progress
---
extra/smalltalk/eval/eval-tests.factor | 6 ++-
extra/smalltalk/parser/parser-tests.factor | 10 +++--
extra/smalltalk/parser/parser.factor | 46 ++++++++++++----------
extra/smalltalk/parser/test.st | 12 +++---
4 files changed, 41 insertions(+), 33 deletions(-)
diff --git a/extra/smalltalk/eval/eval-tests.factor b/extra/smalltalk/eval/eval-tests.factor
index 33f28a2bd8..1dbbd054a8 100644
--- a/extra/smalltalk/eval/eval-tests.factor
+++ b/extra/smalltalk/eval/eval-tests.factor
@@ -1,5 +1,7 @@
IN: smalltalk.eval.tests
-USING: smalltalk.eval tools.test ;
+USING: smalltalk.eval tools.test io.streams.string ;
[ 3 ] [ "1+2" eval-smalltalk ] unit-test
-[ "HAI" ] [ "(1<10) ifTrue:['HAI'] ifFalse:['BAI']" eval-smalltalk ] unit-test
\ No newline at end of file
+[ "HAI" ] [ "(1<10) ifTrue:['HAI'] ifFalse:['BAI']" eval-smalltalk ] unit-test
+[ 7 ] [ "1+2+3;+4" eval-smalltalk ] unit-test
+[ 6 "5\n6\n" ] [ [ "[:x|x print] value: 5; value: 6" eval-smalltalk ] with-string-writer ] unit-test
\ No newline at end of file
diff --git a/extra/smalltalk/parser/parser-tests.factor b/extra/smalltalk/parser/parser-tests.factor
index 1ed6108376..9ba1c38ede 100644
--- a/extra/smalltalk/parser/parser-tests.factor
+++ b/extra/smalltalk/parser/parser-tests.factor
@@ -228,12 +228,12 @@ test = <foreign parse-smalltalk LocalVariableDeclarationList>
[ T{ ast-local-variables f { "i" "j" } } ] [ " | i j |" test-LocalVariableDeclarationList ] unit-test
-EBNF: test-KeywordMessageSend
-test = <foreign parse-smalltalk KeywordMessageSend>
+EBNF: test-MessageSend
+test = <foreign parse-smalltalk MessageSend>
;EBNF
[ T{ ast-message-send f T{ ast-name f "x" } "foo:bar:" { 1 2 } } ]
-[ "x foo:1 bar:2" test-KeywordMessageSend ] unit-test
+[ "x foo:1 bar:2" test-MessageSend ] unit-test
[
T{ ast-message-send
@@ -247,7 +247,7 @@ test = <foreign parse-smalltalk KeywordMessageSend>
{ 10 100 }
}
]
-[ "3 factorial + 4 factorial between: 10 and: 100" test-KeywordMessageSend ] unit-test
+[ "3 factorial + 4 factorial between: 10 and: 100" test-MessageSend ] unit-test
[ T{ ast-sequence f { 1 2 } } ] [ "1. 2" parse-smalltalk ] unit-test
@@ -283,4 +283,6 @@ test = <foreign parse-smalltalk KeywordMessageSend>
]
[ "class Test1 [|a|]. class Test2 extends Test1 [|b|]" parse-smalltalk ] unit-test
+[ ] [ "class Foo []. Tests blah " parse-smalltalk drop ] unit-test
+
[ ] [ "vocab:smalltalk/parser/test.st" ascii file-contents parse-smalltalk drop ] unit-test
diff --git a/extra/smalltalk/parser/parser.factor b/extra/smalltalk/parser/parser.factor
index d6194a9637..c80171e025 100644
--- a/extra/smalltalk/parser/parser.factor
+++ b/extra/smalltalk/parser/parser.factor
@@ -104,7 +104,7 @@ BlockLiteral = "["
"|"
=> [[ args ]]
)?:args
- ExecutableCode:body OptionalWhiteSpace
+ ExecutableCode:body
"]" => [[ args >array body ast-block boa ]]
Literal = (ConstantReference
@@ -125,41 +125,38 @@ Operand = Literal
UnaryMessage = OptionalWhiteSpace
UnaryMessageSelector:s !(":")
=> [[ s { } ast-message boa ]]
-UnaryMessageOperand = UnaryMessageSend | Operand
-UnaryMessageSend = UnaryMessageOperand:receiver
- UnaryMessage:h
- (OptionalWhiteSpace ";" UnaryMessage:m => [[ m ]])*:t
- => [[ receiver t h prefix >array <ast-cascade> ]]
BinaryMessage = OptionalWhiteSpace
BinaryMessageSelector:selector
OptionalWhiteSpace
- BinaryMessageOperand:rhs
+ (MessageSend | Operand):rhs
=> [[ selector { rhs } ast-message boa ]]
-BinaryMessageOperand = BinaryMessageSend | UnaryMessageSend | Operand
-BinaryMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):lhs
- BinaryMessage:h
- (OptionalWhiteSpace ";" BinaryMessage:m => [[ m ]])*:t
- => [[ lhs t h prefix >array <ast-cascade> ]]
-
-KeywordMessageSegment = Keyword:k OptionalWhiteSpace BinaryMessageOperand:arg => [[ { k arg } ]]
+KeywordMessageSegment = Keyword:k OptionalWhiteSpace (BinaryMessageSend | UnaryMessageSend | Operand):arg => [[ { k arg } ]]
KeywordMessage = OptionalWhiteSpace
KeywordMessageSegment:h
(OptionalWhiteSpace KeywordMessageSegment:s => [[ s ]])*:t
=> [[ t h prefix unzip [ concat ] dip ast-message boa ]]
-KeywordMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):receiver
- OptionalWhiteSpace
- KeywordMessage:m
- => [[ receiver m 1array <ast-cascade> ]]
Message = BinaryMessage | UnaryMessage | KeywordMessage
-MessageSend = (MessageSend | Operand):lhs
+UnaryMessageSend = (MessageSend | Operand):lhs
Message:h
(OptionalWhiteSpace ";" Message:m => [[ m ]])*:t
=> [[ lhs t h prefix >array <ast-cascade> ]]
+BinaryMessageSend = (MessageSend | Operand):lhs
+ Message:h
+ (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t
+ => [[ lhs t h prefix >array <ast-cascade> ]]
+
+KeywordMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):lhs
+ KeywordMessage:h
+ (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t
+ => [[ lhs t h prefix >array <ast-cascade> ]]
+
+MessageSend = BinaryMessageSend | UnaryMessageSend | KeywordMessageSend
+
Expression = OptionalWhiteSpace
(MessageSend | Operand):e
=> [[ e ]]
@@ -182,6 +179,7 @@ LocalVariableDeclarationList = OptionalWhiteSpace "|" OptionalWhiteSpace
ExecutableCode = (LocalVariableDeclarationList)?:locals
((Statement:s OptionalWhiteSpace "." => [[ s ]])*:h
FinalStatement:t (".")? => [[ h t suffix ]])?:body
+ OptionalWhiteSpace
=> [[ body locals [ suffix ] when* >array ]]
TopLevelForm = ExecutableCode => [[ ast-sequence boa ]]
@@ -201,7 +199,7 @@ MethodHeader = KeywordMethodHeader
MethodDeclaration = OptionalWhiteSpace "method" OptionalWhiteSpace MethodHeader:header
OptionalWhiteSpace "["
ExecutableCode:code
- OptionalWhiteSpace "]"
+ "]"
=> [[ header first2 code ast-block boa ast-method boa ]]
ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name
@@ -209,7 +207,13 @@ ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name
("extends" OptionalWhiteSpace Identifier:superclass OptionalWhiteSpace => [[ superclass ]])?:superclass
OptionalWhiteSpace "["
(OptionalWhiteSpace LocalVariableDeclarationList:l => [[ l names>> ]])?:ivars
- (MethodDeclaration:h (OptionalWhiteSpace MethodDeclaration:m => [[ m ]])*:t => [[ t h prefix ]])?:methods
+ (MethodDeclaration:h
+ (OptionalWhiteSpace
+ "."
+ OptionalWhiteSpace
+ MethodDeclaration:m => [[ m ]])*:t (".")?
+ => [[ t h prefix ]]
+ )?:methods
OptionalWhiteSpace "]"
=> [[ name superclass "Object" or ivars >array methods >array ast-class boa ]]
diff --git a/extra/smalltalk/parser/test.st b/extra/smalltalk/parser/test.st
index 493d270f9b..8a1ae12145 100644
--- a/extra/smalltalk/parser/test.st
+++ b/extra/smalltalk/parser/test.st
@@ -30,23 +30,23 @@ class TreeNode extends Object [
output
nextPutAll: 'long lived tree of depth '; print: maxDepth; tab;
nextPutAll: ' check: '; print: longLivedTree itemCheck; nl
- ]
+ ].
method binarytrees [
self binarytrees: self arg to: self stdout.
^''
- ]
+ ].
method left: leftChild right: rightChild item: anItem [
left := leftChild.
right := rightChild.
item := anItem
- ]
+ ].
method itemCheck [
^left isNil
ifTrue: [item] ifFalse: [item + (left itemCheck - right itemCheck)]
- ]
+ ].
method bottomUpTree: anItem depth: anInteger [
^(anInteger > 0)
@@ -56,11 +56,11 @@ class TreeNode extends Object [
right: (self bottomUpTree: 2*anItem depth: anInteger - 1)
item: anItem
] ifFalse: [self left: nil right: nil item: anItem]
- ]
+ ].
method left: leftChild right: rightChild item: anItem [
^(super new) left: leftChild right: rightChild item: anItem
]
-]
+].
Tests binarytrees
From 19d8a6a552d30964f8d5a684fc9f1b99f96641bb Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Tue, 31 Mar 2009 23:04:59 -0500
Subject: [PATCH 33/42] remove some dead code, make spider use count and
max-count again
---
extra/spider/spider.factor | 7 ++-----
1 file changed, 2 insertions(+), 5 deletions(-)
diff --git a/extra/spider/spider.factor b/extra/spider/spider.factor
index 0287d50692..d08276a9bb 100644
--- a/extra/spider/spider.factor
+++ b/extra/spider/spider.factor
@@ -8,7 +8,7 @@ continuations calendar prettyprint dlists deques locals ;
IN: spider
TUPLE: spider base count max-count sleep max-depth initial-links
-filters spidered todo nonmatching filtered quiet ;
+filters spidered todo nonmatching quiet ;
TUPLE: spider-result url depth headers fetch-time parsed-html
links processing-time timestamp ;
@@ -40,7 +40,6 @@ TUPLE: unique-deque assoc deque ;
over >>base
swap 0 <unique-deque> [ push-url ] keep >>todo
<unique-deque> >>nonmatching
- <unique-deque> >>filtered
0 >>max-depth
0 >>count
1/0. >>max-count
@@ -60,9 +59,6 @@ TUPLE: unique-deque assoc deque ;
: add-nonmatching ( links level spider -- )
nonmatching>> push-links ;
-: add-filtered ( links level spider -- )
- filtered>> push-links ;
-
: filter-base-links ( spider spider-result -- base-links nonmatching-links )
[ base>> host>> ] [ links>> prune ] bi*
[ host>> = ] with partition ;
@@ -110,6 +106,7 @@ TUPLE: unique-deque assoc deque ;
{
[ todo>> deque>> deque-empty? not ]
[ [ todo>> peek-url depth>> ] [ max-depth>> ] bi < ]
+ [ [ count>> ] [ max-count>> ] bi < ]
} 1&& ;
: setup-next-url ( spider -- spider url depth )
From 9e9116f0eacd11f8daa5c4475472310f6b641615 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@pool-116-90.res.carleton.edu>
Date: Tue, 31 Mar 2009 23:18:52 -0500
Subject: [PATCH 34/42] Better error message for syntax error in : foo ( : bar
---
core/effects/parser/parser.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/core/effects/parser/parser.factor b/core/effects/parser/parser.factor
index b9cb0ddcc9..c8ed6da2aa 100644
--- a/core/effects/parser/parser.factor
+++ b/core/effects/parser/parser.factor
@@ -15,6 +15,7 @@ ERROR: bad-effect ;
scan {
{ "(" [ ")" parse-effect ] }
{ f [ ")" unexpected-eof ] }
+ [ bad-effect ]
} case 2array
] when
] if
@@ -31,4 +32,4 @@ ERROR: bad-effect ;
"(" expect ")" parse-effect ;
: parse-call( ( accum word -- accum )
- [ ")" parse-effect ] dip 2array over push-all ;
\ No newline at end of file
+ [ ")" parse-effect ] dip 2array over push-all ;
From ab7f433aa2dc175e5ac656052092b6cee855ebd7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 31 Mar 2009 23:39:11 -0500
Subject: [PATCH 35/42] Fix stack effect declarations for (>>foo) words
---
core/slots/slots.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/slots/slots.factor b/core/slots/slots.factor
index 46fd325fa5..a353f50947 100755
--- a/core/slots/slots.factor
+++ b/core/slots/slots.factor
@@ -97,7 +97,7 @@ ERROR: bad-slot-value value class ;
"writing" associate ;
: define-writer-generic ( name -- )
- writer-word (( object value -- )) define-simple-generic ;
+ writer-word (( value object -- )) define-simple-generic ;
: define-writer ( class slot-spec -- )
[ nip name>> define-writer-generic ] [
From 474e74a23208760456406ea679639b328518679c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 31 Mar 2009 23:44:38 -0500
Subject: [PATCH 36/42] Re-organize things so that bootstrap.ui doesn't load
ui.text
---
basis/bootstrap/ui/ui.factor | 8 --------
basis/ui/gadgets/worlds/worlds.factor | 13 ++++++++-----
basis/ui/text/core-text/core-text.factor | 5 ++---
basis/ui/text/pango/pango.factor | 5 ++---
basis/ui/text/text.factor | 22 ++++++++++++++++++----
basis/ui/ui.factor | 8 +++-----
6 files changed, 33 insertions(+), 28 deletions(-)
diff --git a/basis/bootstrap/ui/ui.factor b/basis/bootstrap/ui/ui.factor
index 4f7f82a067..271a99c223 100755
--- a/basis/bootstrap/ui/ui.factor
+++ b/basis/bootstrap/ui/ui.factor
@@ -10,12 +10,4 @@ IN: bootstrap.ui
{ [ os unix? ] [ "x11" ] }
} cond
] unless* "ui.backend." prepend require
-
- "ui-text-backend" get [
- {
- { [ os macosx? ] [ "core-text" ] }
- { [ os windows? ] [ "pango" ] }
- { [ os unix? ] [ "pango" ] }
- } cond
- ] unless* "ui.text." prepend require
] when
diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor
index 163dbff514..655c9ba49d 100644
--- a/basis/ui/gadgets/worlds/worlds.factor
+++ b/basis/ui/gadgets/worlds/worlds.factor
@@ -3,8 +3,7 @@
USING: accessors arrays assocs continuations kernel math models
namespaces opengl sequences io combinators combinators.short-circuit
fry math.vectors math.rectangles cache ui.gadgets ui.gestures
-ui.render ui.text ui.text.private ui.backend ui.gadgets.tracks
-ui.commands ;
+ui.render ui.backend ui.gadgets.tracks ui.commands ;
IN: ui.gadgets.worlds
TUPLE: world < track
@@ -53,7 +52,6 @@ M: world request-focus-on ( child gadget -- )
swap >>status
swap >>title
swap 1 track-add
- dup init-text-rendering
dup request-focus ;
: <world> ( gadget title status -- world )
@@ -74,15 +72,20 @@ M: world remove-gadget
2dup layers>> memq?
[ layers>> delq ] [ call-next-method ] if ;
+SYMBOL: flush-layout-cache-hook
+
+flush-layout-cache-hook [ [ ] ] initialize
+
: (draw-world) ( world -- )
dup handle>> [
{
[ init-gl ]
[ draw-gadget ]
- [ finish-text-rendering ]
+ [ text-handle>> [ purge-cache ] when* ]
[ images>> [ purge-cache ] when* ]
} cleave
- ] with-gl-context ;
+ ] with-gl-context
+ flush-layout-cache-hook get call( -- ) ;
: draw-world? ( world -- ? )
#! We don't draw deactivated worlds, or those with 0 size.
diff --git a/basis/ui/text/core-text/core-text.factor b/basis/ui/text/core-text/core-text.factor
index 785a9366cb..3704189e48 100644
--- a/basis/ui/text/core-text/core-text.factor
+++ b/basis/ui/text/core-text/core-text.factor
@@ -18,12 +18,11 @@ M: core-text-renderer string-dim
[ cached-line dim>> ]
if-empty ;
-M: core-text-renderer finish-text-rendering
- text-handle>> purge-cache
+M: core-text-renderer flush-layout-cache
cached-lines get purge-cache ;
: rendered-line ( font string -- texture )
- world get text-handle>>
+ world get world-text-handle
[ cached-line [ image>> ] [ loc>> ] bi <texture> ]
2cache ;
diff --git a/basis/ui/text/pango/pango.factor b/basis/ui/text/pango/pango.factor
index 8b644be469..017a4b2cf2 100755
--- a/basis/ui/text/pango/pango.factor
+++ b/basis/ui/text/pango/pango.factor
@@ -14,12 +14,11 @@ M: pango-renderer string-dim
[ " " string-dim { 0 1 } v* ]
[ cached-layout logical-rect>> dim>> [ >integer ] map ] if-empty ;
-M: pango-renderer finish-text-rendering
- text-handle>> purge-cache
+M: pango-renderer flush-layout-cache
cached-layouts get purge-cache ;
: rendered-layout ( font string -- texture )
- world get text-handle>>
+ world get world-text-handle
[ cached-layout [ image>> ] [ text-position vneg ] bi <texture> ]
2cache ;
diff --git a/basis/ui/text/text.factor b/basis/ui/text/text.factor
index d0766e9ee6..ebf4b9cce0 100644
--- a/basis/ui/text/text.factor
+++ b/basis/ui/text/text.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays sequences math math.order opengl opengl.gl
-strings fonts colors accessors ;
+strings fonts colors accessors namespaces ui.gadgets.worlds ;
IN: ui.text
<PRIVATE
@@ -10,9 +10,13 @@ SYMBOL: font-renderer
HOOK: init-text-rendering font-renderer ( world -- )
-HOOK: finish-text-rendering font-renderer ( world -- )
+: world-text-handle ( world -- handle )
+ dup text-handle>> [ dup init-text-rendering ] unless
+ text-handle>> ;
-M: object finish-text-rendering drop ;
+HOOK: flush-layout-cache font-renderer ( -- )
+
+[ flush-layout-cache ] flush-layout-cache-hook set-global
HOOK: string-dim font-renderer ( font string -- dim )
@@ -68,4 +72,14 @@ M: array draw-text
[ draw-string ]
[ [ 0.0 ] 2dip string-height 0.0 glTranslated ] 2bi
] with each
- ] do-matrix ;
\ No newline at end of file
+ ] do-matrix ;
+
+USING: vocabs.loader namespaces system combinators ;
+
+"ui-backend" get [
+ {
+ { [ os macosx? ] [ "core-text" ] }
+ { [ os windows? ] [ "pango" ] }
+ { [ os unix? ] [ "pango" ] }
+ } cond
+] unless* "ui.text." prepend require
\ No newline at end of file
diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor
index 8ce8f57cf0..bf17e455f8 100644
--- a/basis/ui/ui.factor
+++ b/basis/ui/ui.factor
@@ -4,8 +4,7 @@ USING: arrays assocs io kernel math models namespaces make dlists
deques sequences threads sequences words continuations init
combinators hashtables concurrency.flags sets accessors calendar fry
destructors ui.gadgets ui.gadgets.private ui.gadgets.worlds
-ui.gadgets.tracks ui.gestures ui.backend ui.render ui.text
-ui.text.private ;
+ui.gadgets.tracks ui.gestures ui.backend ui.render ;
IN: ui
<PRIVATE
@@ -63,7 +62,7 @@ M: world graft*
: (ungraft-world) ( world -- )
{
[ handle>> select-gl-context ]
- [ text-handle>> dispose ]
+ [ text-handle>> [ dispose ] when* ]
[ images>> [ dispose ] when* ]
[ hand-clicked close-global ]
[ hand-gadget close-global ]
@@ -95,8 +94,7 @@ M: world ungraft*
: restore-world ( world -- )
{
[ reset-world ]
- [ init-text-rendering ]
- [ f >>images drop ]
+ [ f >>text-handle f >>images drop ]
[ restore-gadget ]
} cleave ;
From 087a7acfba477a5a5c9b90d8de3a2ece5aead5d3 Mon Sep 17 00:00:00 2001
From: Chris Double <chris.double@double.co.nz>
Date: Wed, 1 Apr 2009 17:55:15 +1300
Subject: [PATCH 37/42] Fix peg left recursion handling
---
basis/peg/peg.factor | 23 ++++++++++++++---------
1 file changed, 14 insertions(+), 9 deletions(-)
diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor
index ce34beb725..dda36432e7 100644
--- a/basis/peg/peg.factor
+++ b/basis/peg/peg.factor
@@ -155,18 +155,21 @@ TUPLE: peg-head rule-id involved-set eval-set ;
dup pos>> pos set ans>>
; inline
-:: (setup-lr) ( r l s -- )
- s head>> l head>> eq? [
- l head>> s (>>head)
- l head>> [ s rule-id>> suffix ] change-involved-set drop
- r l s next>> (setup-lr)
- ] unless ;
+:: (setup-lr) ( l s -- )
+ s [
+ s left-recursion? [ s throw ] unless
+ s head>> l head>> eq? [
+ l head>> s (>>head)
+ l head>> [ s rule-id>> suffix ] change-involved-set drop
+ l s next>> (setup-lr)
+ ] unless
+ ] when ;
:: setup-lr ( r l -- )
l head>> [
r rule-id V{ } clone V{ } clone peg-head boa l (>>head)
] unless
- r l lrstack get (setup-lr) ;
+ l lrstack get (setup-lr) ;
:: lr-answer ( r p m -- ast )
[let* |
@@ -216,8 +219,10 @@ TUPLE: peg-head rule-id involved-set eval-set ;
lrstack get next>> lrstack set
pos get m (>>pos)
lr head>> [
- ans lr (>>seed)
- r p m lr-answer
+ m ans>> left-recursion? [
+ ans lr (>>seed)
+ r p m lr-answer
+ ] [ ans ] if
] [
ans m (>>ans)
ans
From 9f01e819e841056d38ef9618f8a581bb8ddd1047 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 1 Apr 2009 02:06:57 -0500
Subject: [PATCH 38/42] smalltalk: fix various things in the parser, add
temporary variable support, clean up compiler
---
extra/smalltalk/ast/ast.factor | 26 ++-
.../smalltalk/compiler/compiler-tests.factor | 9 +-
extra/smalltalk/compiler/compiler.factor | 163 ++++++------------
extra/smalltalk/eval/eval-tests.factor | 4 +-
extra/smalltalk/eval/eval.factor | 8 +-
extra/smalltalk/library/library.factor | 25 ++-
extra/smalltalk/listener/listener.factor | 2 +-
extra/smalltalk/parser/parser-tests.factor | 35 ++--
extra/smalltalk/parser/parser.factor | 36 ++--
extra/smalltalk/parser/test.st | 7 +-
10 files changed, 155 insertions(+), 160 deletions(-)
diff --git a/extra/smalltalk/ast/ast.factor b/extra/smalltalk/ast/ast.factor
index 69bfc3dbf6..e9759b2197 100644
--- a/extra/smalltalk/ast/ast.factor
+++ b/extra/smalltalk/ast/ast.factor
@@ -1,12 +1,12 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: strings arrays memoize kernel sequences accessors ;
+USING: strings arrays memoize kernel sequences accessors combinators ;
IN: smalltalk.ast
SINGLETONS: nil self super ;
TUPLE: ast-comment { string string } ;
-TUPLE: ast-block { arguments array } { body array } ;
+TUPLE: ast-block { arguments array } { temporaries array } { body array } ;
TUPLE: ast-message-send receiver { selector string } { arguments array } ;
TUPLE: ast-message { selector string } { arguments array } ;
TUPLE: ast-cascade receiver { messages array } ;
@@ -17,8 +17,28 @@ TUPLE: ast-local-variables { names array } ;
TUPLE: ast-method { name string } { body ast-block } ;
TUPLE: ast-class { name string } { superclass string } { ivars array } { methods array } ;
TUPLE: ast-foreign { class string } { name string } ;
-TUPLE: ast-sequence { statements array } ;
+TUPLE: ast-sequence { temporaries array } { body array } ;
+! We treat a sequence of statements like a block in a few places to
+! simplify handling of top-level forms
+M: ast-sequence arguments>> drop { } ;
+
+: unclip-temporaries ( statements -- temporaries statements' )
+ {
+ { [ dup empty? ] [ { } ] }
+ { [ dup first ast-local-variables? not ] [ { } ] }
+ [ unclip names>> ]
+ } cond swap ;
+
+: <ast-block> ( arguments body -- block )
+ unclip-temporaries ast-block boa ;
+
+: <ast-sequence> ( body -- block )
+ unclip-temporaries ast-sequence boa ;
+
+! The parser parses normal message sends as cascades with one message, but
+! we represent them differently in the AST to simplify generated code in
+! the common case
: <ast-cascade> ( receiver messages -- ast )
dup length 1 =
[ first [ selector>> ] [ arguments>> ] bi ast-message-send boa ]
diff --git a/extra/smalltalk/compiler/compiler-tests.factor b/extra/smalltalk/compiler/compiler-tests.factor
index c0b9507dd0..81b38f2c14 100644
--- a/extra/smalltalk/compiler/compiler-tests.factor
+++ b/extra/smalltalk/compiler/compiler-tests.factor
@@ -1,10 +1,13 @@
USING: smalltalk.compiler tools.test prettyprint smalltalk.ast
smalltalk.compiler.lexenv stack-checker locals.rewrite.closures
-kernel accessors compiler.units sequences ;
+kernel accessors compiler.units sequences arrays ;
IN: smalltalk.compiler.tests
: test-compilation ( ast -- quot )
- [ compile-smalltalk [ call ] append ] with-compilation-unit ;
+ [
+ 1array ast-sequence new swap >>body
+ compile-smalltalk [ call ] append
+ ] with-compilation-unit ;
: test-inference ( ast -- in# out# )
test-compilation infer [ in>> ] [ out>> ] bi ;
@@ -46,6 +49,7 @@ IN: smalltalk.compiler.tests
[ 0 1 ] [
T{ ast-block f
+ { }
{ }
{
T{ ast-message-send
@@ -76,6 +80,7 @@ IN: smalltalk.compiler.tests
[ "a" ] [
T{ ast-block f
+ { }
{ }
{ { T{ ast-block { body { "a" } } } } }
} test-compilation call first call
diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor
index 4a2417e91d..e61b44ffae 100644
--- a/extra/smalltalk/compiler/compiler.factor
+++ b/extra/smalltalk/compiler/compiler.factor
@@ -2,77 +2,12 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators.short-circuit
continuations fry kernel namespaces quotations sequences sets
-generalizations slots locals.types generalizations splitting math
-locals.rewrite.closures generic words combinators smalltalk.ast
-smalltalk.compiler.lexenv smalltalk.selectors
-smalltalk.classes ;
+generalizations slots locals.types splitting math
+locals.rewrite.closures generic words combinators locals smalltalk.ast
+smalltalk.compiler.lexenv smalltalk.compiler.assignment
+smalltalk.compiler.return smalltalk.selectors smalltalk.classes ;
IN: smalltalk.compiler
-SYMBOL: return-continuation
-
-GENERIC: need-return-continuation? ( ast -- ? )
-
-M: ast-return need-return-continuation? drop t ;
-
-M: ast-block need-return-continuation? body>> need-return-continuation? ;
-
-M: ast-message-send need-return-continuation?
- {
- [ receiver>> need-return-continuation? ]
- [ arguments>> need-return-continuation? ]
- } 1&& ;
-
-M: ast-cascade need-return-continuation?
- {
- [ receiver>> need-return-continuation? ]
- [ messages>> need-return-continuation? ]
- } 1&& ;
-
-M: ast-message need-return-continuation?
- arguments>> need-return-continuation? ;
-
-M: ast-assignment need-return-continuation?
- value>> need-return-continuation? ;
-
-M: ast-sequence need-return-continuation?
- statements>> need-return-continuation? ;
-
-M: array need-return-continuation? [ need-return-continuation? ] any? ;
-
-M: object need-return-continuation? drop f ;
-
-GENERIC: assigned-locals ( ast -- seq )
-
-M: ast-return assigned-locals value>> assigned-locals ;
-
-M: ast-block assigned-locals
- [ body>> assigned-locals ] [ arguments>> ] bi diff ;
-
-M: ast-message-send assigned-locals
- [ receiver>> assigned-locals ]
- [ arguments>> assigned-locals ]
- bi append ;
-
-M: ast-cascade assigned-locals
- [ arguments>> assigned-locals ]
- [ messages>> assigned-locals ]
- bi append ;
-
-M: ast-message assigned-locals
- arguments>> assigned-locals ;
-
-M: ast-assignment assigned-locals
- [ name>> dup ast-name? [ name>> 1array ] [ drop { } ] if ]
- [ value>> assigned-locals ] bi append ;
-
-M: ast-sequence assigned-locals
- statements>> assigned-locals ;
-
-M: array assigned-locals
- [ assigned-locals ] map concat ;
-
-M: object assigned-locals drop f ;
-
GENERIC: compile-ast ( lexenv ast -- quot )
M: object compile-ast nip 1quotation ;
@@ -108,11 +43,39 @@ M: ast-return compile-ast
value>> compile-ast
[ return-continuation get continue-with ] append ;
-: compile-sequence ( lexenv asts -- quot )
- [ drop [ nil ] ] [ [ compile-ast ] with map [ drop ] join ] if-empty ;
+: (compile-sequence) ( lexenv asts -- quot )
+ [ drop [ nil ] ] [
+ [ compile-ast ] with map [ drop ] join
+ ] if-empty ;
+
+: block-lexenv ( block -- lexenv )
+ [ [ arguments>> ] [ temporaries>> ] bi append ]
+ [ body>> [ assigned-locals ] map concat unique ] bi
+ '[
+ dup dup _ key?
+ [ <local-reader> ]
+ [ <local> ]
+ if
+ ] H{ } map>assoc
+ dup
+ [ nip local-reader? ] assoc-filter
+ [ <local-writer> ] assoc-map
+ <lexenv> swap >>local-writers swap >>local-readers ;
+
+: lookup-block-vars ( vars lexenv -- seq )
+ local-readers>> '[ _ at ] map ;
+
+: make-temporaries ( block lexenv -- quot )
+ [ temporaries>> ] dip lookup-block-vars
+ [ <def> [ f ] swap suffix ] map [ ] join ;
+
+:: compile-sequence ( lexenv block -- vars quot )
+ lexenv block block-lexenv lexenv-union :> lexenv
+ block arguments>> lexenv lookup-block-vars
+ lexenv block body>> (compile-sequence) block lexenv make-temporaries prepend ;
M: ast-sequence compile-ast
- statements>> compile-sequence ;
+ compile-sequence nip ;
GENERIC: contains-blocks? ( obj -- ? )
@@ -135,48 +98,12 @@ M: ast-name compile-assignment name>> swap lookup-writer ;
M: ast-assignment compile-ast
[ value>> compile-ast [ dup ] ] [ name>> compile-assignment ] 2bi 3append ;
-: block-lexenv ( block -- lexenv )
- [ arguments>> ] [ body>> [ assigned-locals ] map concat unique ] bi
- '[
- dup dup _ key?
- [ <local-reader> ]
- [ <local> ]
- if
- ] { } map>assoc
- dup
- [ nip local-reader? ] assoc-filter
- [ <local-writer> ] assoc-map
- <lexenv> swap >>local-writers swap >>local-readers ;
-
-: compile-block ( lexenv block -- vars body )
- [
- block-lexenv
- [ nip local-readers>> values ]
- [ lexenv-union ] 2bi
- ] [ body>> ] bi
- compile-sequence ;
-
M: ast-block compile-ast
- compile-block <lambda> '[ _ ] ;
+ compile-sequence <lambda> '[ _ ] ;
-: make-return ( quot n block -- quot )
- need-return-continuation? [
- '[
- [
- _ _ ncurry
- [ return-continuation set ] prepose callcc1
- ] with-scope
- ]
- ] [ drop ] if
- rewrite-closures first ;
-
-GENERIC: compile-smalltalk ( ast -- quot )
-
-M: object compile-smalltalk ( statement -- quot )
- [ [ empty-lexenv ] dip compile-ast 0 ] keep make-return ;
-
-: (compile-method-body) ( lexenv block -- lambda )
- [ drop self>> ] [ compile-block ] 2bi [ swap suffix ] dip <lambda> ;
+:: (compile-method-body) ( lexenv block -- lambda )
+ lexenv block compile-sequence
+ [ lexenv self>> suffix ] dip <lambda> ;
: compile-method-body ( lexenv block -- quot )
[ [ (compile-method-body) ] [ arguments>> length 1+ ] bi ] keep
@@ -190,7 +117,8 @@ M: object compile-smalltalk ( statement -- quot )
: <class-lexenv> ( class -- lexenv )
<lexenv> swap >>class "self" <local-reader> >>self ;
-M: ast-class compile-smalltalk ( ast-class -- quot )
+M: ast-class compile-ast
+ nip
[
[ name>> ] [ superclass>> ] [ ivars>> ] tri
define-class <class-lexenv>
@@ -201,7 +129,12 @@ M: ast-class compile-smalltalk ( ast-class -- quot )
ERROR: no-word name ;
-M: ast-foreign compile-smalltalk
+M: ast-foreign compile-ast
+ nip
[ class>> dup ":" split1 lookup [ ] [ no-word ] ?if ]
[ name>> ] bi define-foreign
- [ nil ] ;
\ No newline at end of file
+ [ nil ] ;
+
+: compile-smalltalk ( statement -- quot )
+ [ [ empty-lexenv ] dip compile-sequence nip 0 ]
+ keep make-return ;
\ No newline at end of file
diff --git a/extra/smalltalk/eval/eval-tests.factor b/extra/smalltalk/eval/eval-tests.factor
index 1dbbd054a8..8a7756054a 100644
--- a/extra/smalltalk/eval/eval-tests.factor
+++ b/extra/smalltalk/eval/eval-tests.factor
@@ -4,4 +4,6 @@ USING: smalltalk.eval tools.test io.streams.string ;
[ 3 ] [ "1+2" eval-smalltalk ] unit-test
[ "HAI" ] [ "(1<10) ifTrue:['HAI'] ifFalse:['BAI']" eval-smalltalk ] unit-test
[ 7 ] [ "1+2+3;+4" eval-smalltalk ] unit-test
-[ 6 "5\n6\n" ] [ [ "[:x|x print] value: 5; value: 6" eval-smalltalk ] with-string-writer ] unit-test
\ No newline at end of file
+[ 6 "5\n6\n" ] [ [ "[:x|x print] value: 5; value: 6" eval-smalltalk ] with-string-writer ] unit-test
+[ 5 ] [ "|x| x:=5. x" eval-smalltalk ] unit-test
+[ 11 ] [ "[:i| |x| x:=5. i+x] value: 6" eval-smalltalk ] unit-test
diff --git a/extra/smalltalk/eval/eval.factor b/extra/smalltalk/eval/eval.factor
index 60f0d9cce2..d874000a0f 100644
--- a/extra/smalltalk/eval/eval.factor
+++ b/extra/smalltalk/eval/eval.factor
@@ -1,8 +1,12 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.units smalltalk.parser smalltalk.compiler ;
+USING: io.files io.encodings.utf8
+compiler.units smalltalk.parser smalltalk.compiler ;
IN: smalltalk.eval
: eval-smalltalk ( string -- result )
[ parse-smalltalk compile-smalltalk ] with-compilation-unit
- call( -- result ) ;
\ No newline at end of file
+ call( -- result ) ;
+
+: eval-smalltalk-file ( path -- result )
+ utf8 file-contents eval-smalltalk ;
diff --git a/extra/smalltalk/library/library.factor b/extra/smalltalk/library/library.factor
index 1a8cb8d177..28acf98dff 100644
--- a/extra/smalltalk/library/library.factor
+++ b/extra/smalltalk/library/library.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel present io math sequences assocs math.ranges fry
-tools.time locals smalltalk.selectors smalltalk.ast smalltalk.classes ;
+USING: kernel present io math sequences assocs math.ranges
+math.order fry tools.time locals smalltalk.selectors
+smalltalk.ast smalltalk.classes ;
IN: smalltalk.library
SELECTOR: print
@@ -10,6 +11,16 @@ SELECTOR: asString
M: object selector-print dup present print ;
M: object selector-asString present ;
+SELECTOR: print:
+SELECTOR: nextPutAll:
+SELECTOR: tab
+SELECTOR: nl
+
+M: object selector-print: [ present ] dip stream-print nil ;
+M: object selector-nextPutAll: selector-print: ;
+M: object selector-tab " " swap selector-print: ;
+M: object selector-nl stream-nl nil ;
+
SELECTOR: +
SELECTOR: -
SELECTOR: *
@@ -30,6 +41,12 @@ M: object selector-<= swap <= ;
M: object selector->= swap >= ;
M: object selector-= swap = ;
+SELECTOR: min:
+SELECTOR: max:
+
+M: object selector-min: min ;
+M: object selector-max: max ;
+
SELECTOR: ifTrue:
SELECTOR: ifFalse:
SELECTOR: ifTrue:ifFalse:
@@ -38,6 +55,10 @@ M: object selector-ifTrue: [ call( -- result ) ] [ drop nil ] if ;
M: object selector-ifFalse: [ drop nil ] [ call( -- result ) ] if ;
M: object selector-ifTrue:ifFalse: [ drop call( -- result ) ] [ nip call( -- result ) ] if ;
+SELECTOR: isNil
+
+M: object selector-isNil nil eq? ;
+
SELECTOR: at:
SELECTOR: at:put:
diff --git a/extra/smalltalk/listener/listener.factor b/extra/smalltalk/listener/listener.factor
index e052f0c629..dc84fd90fb 100644
--- a/extra/smalltalk/listener/listener.factor
+++ b/extra/smalltalk/listener/listener.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel prettyprint io io.styles colors.constants compiler.units
fry debugger sequences locals.rewrite.closures smalltalk.ast
-smalltalk.eval smalltalk.printer ;
+smalltalk.eval smalltalk.printer smalltalk.listener ;
IN: smalltalk.listener
: eval-interactively ( string -- )
diff --git a/extra/smalltalk/parser/parser-tests.factor b/extra/smalltalk/parser/parser-tests.factor
index 9ba1c38ede..ff9cbc208b 100644
--- a/extra/smalltalk/parser/parser-tests.factor
+++ b/extra/smalltalk/parser/parser-tests.factor
@@ -49,9 +49,9 @@ test = <foreign parse-smalltalk Literal>
[ B{ 1 2 3 4 } ] [ "#[1 2 3 4]" test-Literal ] unit-test
[ { nil t f } ] [ "#(nil true false)" test-Literal ] unit-test
[ { nil { t f } } ] [ "#(nil (true false))" test-Literal ] unit-test
-[ T{ ast-block f { } { } } ] [ "[]" test-Literal ] unit-test
-[ T{ ast-block f { "x" } { T{ ast-return f T{ ast-name f "x" } } } } ] [ "[ :x|^x]" test-Literal ] unit-test
-[ T{ ast-block f { } { T{ ast-return f self } } } ] [ "[^self]" test-Literal ] unit-test
+[ T{ ast-block f { } { } { } } ] [ "[]" test-Literal ] unit-test
+[ T{ ast-block f { "x" } { } { T{ ast-return f T{ ast-name f "x" } } } } ] [ "[ :x|^x]" test-Literal ] unit-test
+[ T{ ast-block f { } { } { T{ ast-return f self } } } ] [ "[^self]" test-Literal ] unit-test
[
T{ ast-block
@@ -190,6 +190,19 @@ test = <foreign parse-smalltalk Expression>
]
[ "12 sqrt + 1; + 2" test-Expression ] unit-test
+[
+ T{ ast-cascade
+ { receiver T{ ast-message-send f 12 "squared" } }
+ { messages
+ {
+ T{ ast-message f "to:" { 100 } }
+ T{ ast-message f "sqrt" }
+ }
+ }
+ }
+]
+[ "12 squared to: 100; sqrt" test-Expression ] unit-test
+
[
T{ ast-message-send f
T{ ast-message-send f 1 "+" { 2 } }
@@ -228,12 +241,8 @@ test = <foreign parse-smalltalk LocalVariableDeclarationList>
[ T{ ast-local-variables f { "i" "j" } } ] [ " | i j |" test-LocalVariableDeclarationList ] unit-test
-EBNF: test-MessageSend
-test = <foreign parse-smalltalk MessageSend>
-;EBNF
-
[ T{ ast-message-send f T{ ast-name f "x" } "foo:bar:" { 1 2 } } ]
-[ "x foo:1 bar:2" test-MessageSend ] unit-test
+[ "x foo:1 bar:2" test-Expression ] unit-test
[
T{ ast-message-send
@@ -247,12 +256,14 @@ test = <foreign parse-smalltalk MessageSend>
{ 10 100 }
}
]
-[ "3 factorial + 4 factorial between: 10 and: 100" test-MessageSend ] unit-test
+[ "3 factorial + 4 factorial between: 10 and: 100" test-Expression ] unit-test
-[ T{ ast-sequence f { 1 2 } } ] [ "1. 2" parse-smalltalk ] unit-test
+[ T{ ast-sequence f { } { 1 2 } } ] [ "1. 2" parse-smalltalk ] unit-test
+
+[ T{ ast-sequence f { } { 1 2 } } ] [ "1. 2." parse-smalltalk ] unit-test
[
- T{ ast-sequence f
+ T{ ast-sequence f { }
{
T{ ast-class
{ name "Test" }
@@ -265,7 +276,7 @@ test = <foreign parse-smalltalk MessageSend>
[ "class Test [|a|]" parse-smalltalk ] unit-test
[
- T{ ast-sequence f
+ T{ ast-sequence f { }
{
T{ ast-class
{ name "Test1" }
diff --git a/extra/smalltalk/parser/parser.factor b/extra/smalltalk/parser/parser.factor
index c80171e025..1958861606 100644
--- a/extra/smalltalk/parser/parser.factor
+++ b/extra/smalltalk/parser/parser.factor
@@ -105,7 +105,7 @@ BlockLiteral = "["
=> [[ args ]]
)?:args
ExecutableCode:body
- "]" => [[ args >array body ast-block boa ]]
+ "]" => [[ args >array body <ast-block> ]]
Literal = (ConstantReference
| FloatingPointLiteral
@@ -129,7 +129,7 @@ UnaryMessage = OptionalWhiteSpace
BinaryMessage = OptionalWhiteSpace
BinaryMessageSelector:selector
OptionalWhiteSpace
- (MessageSend | Operand):rhs
+ (UnaryMessageSend | Operand):rhs
=> [[ selector { rhs } ast-message boa ]]
KeywordMessageSegment = Keyword:k OptionalWhiteSpace (BinaryMessageSend | UnaryMessageSend | Operand):arg => [[ { k arg } ]]
@@ -140,13 +140,13 @@ KeywordMessage = OptionalWhiteSpace
Message = BinaryMessage | UnaryMessage | KeywordMessage
-UnaryMessageSend = (MessageSend | Operand):lhs
- Message:h
+UnaryMessageSend = (UnaryMessageSend | Operand):lhs
+ UnaryMessage:h
(OptionalWhiteSpace ";" Message:m => [[ m ]])*:t
=> [[ lhs t h prefix >array <ast-cascade> ]]
-BinaryMessageSend = (MessageSend | Operand):lhs
- Message:h
+BinaryMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):lhs
+ BinaryMessage:h
(OptionalWhiteSpace ";" Message:m => [[ m ]])*:t
=> [[ lhs t h prefix >array <ast-cascade> ]]
@@ -155,10 +155,8 @@ KeywordMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):lhs
(OptionalWhiteSpace ";" Message:m => [[ m ]])*:t
=> [[ lhs t h prefix >array <ast-cascade> ]]
-MessageSend = BinaryMessageSend | UnaryMessageSend | KeywordMessageSend
-
Expression = OptionalWhiteSpace
- (MessageSend | Operand):e
+ (KeywordMessageSend | BinaryMessageSend | UnaryMessageSend | Operand):e
=> [[ e ]]
AssignmentOperation = OptionalWhiteSpace BindableIdentifier:i
@@ -176,13 +174,15 @@ LocalVariableDeclarationList = OptionalWhiteSpace "|" OptionalWhiteSpace
=> [[ t h prefix ]]
)?:b OptionalWhiteSpace "|" => [[ b >array ast-local-variables boa ]]
-ExecutableCode = (LocalVariableDeclarationList)?:locals
- ((Statement:s OptionalWhiteSpace "." => [[ s ]])*:h
- FinalStatement:t (".")? => [[ h t suffix ]])?:body
- OptionalWhiteSpace
- => [[ body locals [ suffix ] when* >array ]]
+EndStatement = "."
-TopLevelForm = ExecutableCode => [[ ast-sequence boa ]]
+ExecutableCode = (LocalVariableDeclarationList)?:locals
+ (Statement:s OptionalWhiteSpace EndStatement => [[ s ]])*:h
+ (FinalStatement:t (EndStatement)? => [[ t ]])?:t
+ OptionalWhiteSpace
+ => [[ h t [ suffix ] when* locals [ prefix ] when* >array ]]
+
+TopLevelForm = ExecutableCode => [[ <ast-sequence> ]]
UnaryMethodHeader = UnaryMessageSelector:selector
=> [[ { selector { } } ]]
@@ -200,7 +200,7 @@ MethodDeclaration = OptionalWhiteSpace "method" OptionalWhiteSpace MethodHeader:
OptionalWhiteSpace "["
ExecutableCode:code
"]"
- => [[ header first2 code ast-block boa ast-method boa ]]
+ => [[ header first2 code <ast-block> ast-method boa ]]
ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name
OptionalWhiteSpace
@@ -209,9 +209,9 @@ ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name
(OptionalWhiteSpace LocalVariableDeclarationList:l => [[ l names>> ]])?:ivars
(MethodDeclaration:h
(OptionalWhiteSpace
- "."
+ EndStatement
OptionalWhiteSpace
- MethodDeclaration:m => [[ m ]])*:t (".")?
+ MethodDeclaration:m => [[ m ]])*:t (EndStatement)?
=> [[ t h prefix ]]
)?:methods
OptionalWhiteSpace "]"
diff --git a/extra/smalltalk/parser/test.st b/extra/smalltalk/parser/test.st
index 8a1ae12145..063f20882a 100644
--- a/extra/smalltalk/parser/test.st
+++ b/extra/smalltalk/parser/test.st
@@ -31,9 +31,9 @@ class TreeNode extends Object [
nextPutAll: 'long lived tree of depth '; print: maxDepth; tab;
nextPutAll: ' check: '; print: longLivedTree itemCheck; nl
].
-
- method binarytrees [
- self binarytrees: self arg to: self stdout.
+
+ method binarytrees: arg [
+ self binarytrees: arg to: self stdout.
^''
].
@@ -63,4 +63,3 @@ class TreeNode extends Object [
]
].
-Tests binarytrees
From 0ff66788503d96999b4b273a5bfe8c5fda8aab5f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 1 Apr 2009 02:08:49 -0500
Subject: [PATCH 39/42] Load smalltalk.library by default and remove useless
smalltalk.factor
---
extra/smalltalk/eval/eval.factor | 3 ++-
extra/smalltalk/smalltalk.factor | 4 ----
2 files changed, 2 insertions(+), 5 deletions(-)
delete mode 100644 extra/smalltalk/smalltalk.factor
diff --git a/extra/smalltalk/eval/eval.factor b/extra/smalltalk/eval/eval.factor
index d874000a0f..56841beafd 100644
--- a/extra/smalltalk/eval/eval.factor
+++ b/extra/smalltalk/eval/eval.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io.encodings.utf8
-compiler.units smalltalk.parser smalltalk.compiler ;
+compiler.units smalltalk.parser smalltalk.compiler
+smalltalk.library ;
IN: smalltalk.eval
: eval-smalltalk ( string -- result )
diff --git a/extra/smalltalk/smalltalk.factor b/extra/smalltalk/smalltalk.factor
deleted file mode 100644
index 27cd9912ed..0000000000
--- a/extra/smalltalk/smalltalk.factor
+++ /dev/null
@@ -1,4 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: ;
-IN: smalltalk
From 8ab7328899458ad12c391272a7e0018bddbca742 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 1 Apr 2009 02:09:49 -0500
Subject: [PATCH 40/42] Add new vocabs
---
.../compiler/assignment/assignment.factor | 36 +++++++++++++
.../smalltalk/compiler/assignment/authors.txt | 1 +
extra/smalltalk/compiler/return/authors.txt | 1 +
extra/smalltalk/compiler/return/return.factor | 50 +++++++++++++++++++
4 files changed, 88 insertions(+)
create mode 100644 extra/smalltalk/compiler/assignment/assignment.factor
create mode 100644 extra/smalltalk/compiler/assignment/authors.txt
create mode 100644 extra/smalltalk/compiler/return/authors.txt
create mode 100644 extra/smalltalk/compiler/return/return.factor
diff --git a/extra/smalltalk/compiler/assignment/assignment.factor b/extra/smalltalk/compiler/assignment/assignment.factor
new file mode 100644
index 0000000000..3a0a769f86
--- /dev/null
+++ b/extra/smalltalk/compiler/assignment/assignment.factor
@@ -0,0 +1,36 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel sequences sets smalltalk.ast ;
+IN: smalltalk.compiler.assignment
+
+GENERIC: assigned-locals ( ast -- seq )
+
+M: ast-return assigned-locals value>> assigned-locals ;
+
+M: ast-block assigned-locals
+ [ body>> assigned-locals ] [ arguments>> ] bi diff ;
+
+M: ast-message-send assigned-locals
+ [ receiver>> assigned-locals ]
+ [ arguments>> assigned-locals ]
+ bi append ;
+
+M: ast-cascade assigned-locals
+ [ receiver>> assigned-locals ]
+ [ messages>> assigned-locals ]
+ bi append ;
+
+M: ast-message assigned-locals
+ arguments>> assigned-locals ;
+
+M: ast-assignment assigned-locals
+ [ name>> dup ast-name? [ name>> 1array ] [ drop { } ] if ]
+ [ value>> assigned-locals ] bi append ;
+
+M: ast-sequence assigned-locals
+ body>> assigned-locals ;
+
+M: array assigned-locals
+ [ assigned-locals ] map concat ;
+
+M: object assigned-locals drop f ;
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/assignment/authors.txt b/extra/smalltalk/compiler/assignment/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/compiler/assignment/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/return/authors.txt b/extra/smalltalk/compiler/return/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/compiler/return/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/return/return.factor b/extra/smalltalk/compiler/return/return.factor
new file mode 100644
index 0000000000..31b4a1511b
--- /dev/null
+++ b/extra/smalltalk/compiler/return/return.factor
@@ -0,0 +1,50 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays combinators.short-circuit continuations
+fry generalizations kernel locals.rewrite.closures namespaces
+sequences smalltalk.ast ;
+IN: smalltalk.compiler.return
+
+SYMBOL: return-continuation
+
+GENERIC: need-return-continuation? ( ast -- ? )
+
+M: ast-return need-return-continuation? drop t ;
+
+M: ast-block need-return-continuation? body>> need-return-continuation? ;
+
+M: ast-message-send need-return-continuation?
+ {
+ [ receiver>> need-return-continuation? ]
+ [ arguments>> need-return-continuation? ]
+ } 1&& ;
+
+M: ast-cascade need-return-continuation?
+ {
+ [ receiver>> need-return-continuation? ]
+ [ messages>> need-return-continuation? ]
+ } 1&& ;
+
+M: ast-message need-return-continuation?
+ arguments>> need-return-continuation? ;
+
+M: ast-assignment need-return-continuation?
+ value>> need-return-continuation? ;
+
+M: ast-sequence need-return-continuation?
+ body>> need-return-continuation? ;
+
+M: array need-return-continuation? [ need-return-continuation? ] any? ;
+
+M: object need-return-continuation? drop f ;
+
+: make-return ( quot n block -- quot )
+ need-return-continuation? [
+ '[
+ [
+ _ _ ncurry
+ [ return-continuation set ] prepose callcc1
+ ] with-scope
+ ]
+ ] [ drop ] if
+ rewrite-closures first ;
\ No newline at end of file
From 3885ba02a6cdf78682f06d75d3865e5183084987 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 1 Apr 2009 02:47:51 -0500
Subject: [PATCH 41/42] Fixing up smalltalk to the point where it can run fib,
slowly
---
extra/smalltalk/ast/ast.factor | 4 +++
extra/smalltalk/compiler/compiler.factor | 31 +++++++++++++------
extra/smalltalk/compiler/lexenv/lexenv.factor | 3 +-
.../compiler/return/return-tests.factor | 3 ++
extra/smalltalk/compiler/return/return.factor | 23 ++++++--------
extra/smalltalk/eval/eval-tests.factor | 4 ++-
extra/smalltalk/eval/fib.st | 11 +++++++
extra/smalltalk/parser/parser-tests.factor | 5 +--
extra/smalltalk/parser/parser.factor | 2 +-
9 files changed, 57 insertions(+), 29 deletions(-)
create mode 100644 extra/smalltalk/compiler/return/return-tests.factor
create mode 100644 extra/smalltalk/eval/fib.st
diff --git a/extra/smalltalk/ast/ast.factor b/extra/smalltalk/ast/ast.factor
index e9759b2197..fc415aa361 100644
--- a/extra/smalltalk/ast/ast.factor
+++ b/extra/smalltalk/ast/ast.factor
@@ -45,5 +45,9 @@ M: ast-sequence arguments>> drop { } ;
[ ast-cascade boa ]
if ;
+! Methods return self by default
+: <ast-method> ( class arguments body -- method )
+ self suffix <ast-block> ast-method boa ;
+
TUPLE: symbol { name string } ;
MEMO: intern ( name -- symbol ) symbol boa ;
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor
index e61b44ffae..0b6f17e3fa 100644
--- a/extra/smalltalk/compiler/compiler.factor
+++ b/extra/smalltalk/compiler/compiler.factor
@@ -21,11 +21,22 @@ M: ast-name compile-ast name>> swap lookup-reader ;
: compile-arguments ( lexenv ast -- quot )
arguments>> [ compile-ast ] with map [ ] join ;
-M: ast-message-send compile-ast
- [ compile-arguments ]
+: compile-ifTrue:ifFalse: ( lexenv ast -- quot )
[ receiver>> compile-ast ]
- [ nip selector>> selector>generic ]
- 2tri [ append ] dip suffix ;
+ [ compile-arguments ] 2bi
+ [ if ] 3append ;
+
+M: ast-message-send compile-ast
+ dup selector>> {
+ { "ifTrue:ifFalse:" [ compile-ifTrue:ifFalse: ] }
+ [
+ drop
+ [ compile-arguments ]
+ [ receiver>> compile-ast ]
+ [ nip selector>> selector>generic ]
+ 2tri [ append ] dip suffix
+ ]
+ } case ;
M: ast-cascade compile-ast
[ receiver>> compile-ast ]
@@ -40,8 +51,8 @@ M: ast-cascade compile-ast
] 2bi append ;
M: ast-return compile-ast
- value>> compile-ast
- [ return-continuation get continue-with ] append ;
+ [ value>> compile-ast ] [ drop return>> 1quotation ] 2bi
+ [ continue-with ] 3append ;
: (compile-sequence) ( lexenv asts -- quot )
[ drop [ nil ] ] [
@@ -106,7 +117,7 @@ M: ast-block compile-ast
[ lexenv self>> suffix ] dip <lambda> ;
: compile-method-body ( lexenv block -- quot )
- [ [ (compile-method-body) ] [ arguments>> length 1+ ] bi ] keep
+ [ [ (compile-method-body) ] [ arguments>> length 1+ ] bi ] 2keep
make-return ;
: compile-method ( lexenv ast-method -- )
@@ -115,7 +126,7 @@ M: ast-block compile-ast
2bi define ;
: <class-lexenv> ( class -- lexenv )
- <lexenv> swap >>class "self" <local-reader> >>self ;
+ <lexenv> swap >>class "self" <local> >>self "^" <local> >>return ;
M: ast-class compile-ast
nip
@@ -136,5 +147,5 @@ M: ast-foreign compile-ast
[ nil ] ;
: compile-smalltalk ( statement -- quot )
- [ [ empty-lexenv ] dip compile-sequence nip 0 ]
- keep make-return ;
\ No newline at end of file
+ [ empty-lexenv ] dip [ compile-sequence nip 0 ]
+ 2keep make-return ;
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/lexenv/lexenv.factor b/extra/smalltalk/compiler/lexenv/lexenv.factor
index 6b6d283761..cd06314fd9 100644
--- a/extra/smalltalk/compiler/lexenv/lexenv.factor
+++ b/extra/smalltalk/compiler/lexenv/lexenv.factor
@@ -10,7 +10,7 @@ IN: smalltalk.compiler.lexenv
! self: word or f for top-level forms
! class: class word or f for top-level forms
! method: generic word or f for top-level forms
-TUPLE: lexenv local-readers local-writers self class method ;
+TUPLE: lexenv local-readers local-writers self return class method ;
: <lexenv> ( -- lexenv ) lexenv new ; inline
@@ -21,6 +21,7 @@ CONSTANT: empty-lexenv T{ lexenv }
[ [ local-readers>> ] bi@ assoc-union >>local-readers ]
[ [ local-writers>> ] bi@ assoc-union >>local-writers ]
[ [ self>> ] either? >>self ]
+ [ [ return>> ] either? >>return ]
[ [ class>> ] either? >>class ]
[ [ method>> ] either? >>method ]
} 2cleave ;
diff --git a/extra/smalltalk/compiler/return/return-tests.factor b/extra/smalltalk/compiler/return/return-tests.factor
new file mode 100644
index 0000000000..15a3406ffc
--- /dev/null
+++ b/extra/smalltalk/compiler/return/return-tests.factor
@@ -0,0 +1,3 @@
+USING: smalltalk.parser smalltalk.compiler.return tools.test ;
+
+[ t ] [ "(i <= 1) ifTrue: [^1] ifFalse: [^((Fib new i:(i-1)) compute + (Fib new i:(i-2)) compute)]" parse-smalltalk need-return-continuation? ] unit-test
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/return/return.factor b/extra/smalltalk/compiler/return/return.factor
index 31b4a1511b..8c36bdac64 100644
--- a/extra/smalltalk/compiler/return/return.factor
+++ b/extra/smalltalk/compiler/return/return.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators.short-circuit continuations
-fry generalizations kernel locals.rewrite.closures namespaces
-sequences smalltalk.ast ;
+fry generalizations kernel locals locals.types locals.rewrite.closures
+namespaces make sequences smalltalk.ast ;
IN: smalltalk.compiler.return
SYMBOL: return-continuation
@@ -17,13 +17,13 @@ M: ast-message-send need-return-continuation?
{
[ receiver>> need-return-continuation? ]
[ arguments>> need-return-continuation? ]
- } 1&& ;
+ } 1|| ;
M: ast-cascade need-return-continuation?
{
[ receiver>> need-return-continuation? ]
[ messages>> need-return-continuation? ]
- } 1&& ;
+ } 1|| ;
M: ast-message need-return-continuation?
arguments>> need-return-continuation? ;
@@ -38,13 +38,8 @@ M: array need-return-continuation? [ need-return-continuation? ] any? ;
M: object need-return-continuation? drop f ;
-: make-return ( quot n block -- quot )
- need-return-continuation? [
- '[
- [
- _ _ ncurry
- [ return-continuation set ] prepose callcc1
- ] with-scope
- ]
- ] [ drop ] if
- rewrite-closures first ;
\ No newline at end of file
+:: make-return ( quot n lexenv block -- quot )
+ block need-return-continuation? [
+ quot clone [ lexenv return>> <def> '[ _ ] prepend ] change-body
+ n '[ _ _ ncurry callcc1 ]
+ ] [ quot ] if rewrite-closures first ;
\ No newline at end of file
diff --git a/extra/smalltalk/eval/eval-tests.factor b/extra/smalltalk/eval/eval-tests.factor
index 8a7756054a..95366d65b9 100644
--- a/extra/smalltalk/eval/eval-tests.factor
+++ b/extra/smalltalk/eval/eval-tests.factor
@@ -1,5 +1,5 @@
IN: smalltalk.eval.tests
-USING: smalltalk.eval tools.test io.streams.string ;
+USING: smalltalk.eval tools.test io.streams.string kernel ;
[ 3 ] [ "1+2" eval-smalltalk ] unit-test
[ "HAI" ] [ "(1<10) ifTrue:['HAI'] ifFalse:['BAI']" eval-smalltalk ] unit-test
@@ -7,3 +7,5 @@ USING: smalltalk.eval tools.test io.streams.string ;
[ 6 "5\n6\n" ] [ [ "[:x|x print] value: 5; value: 6" eval-smalltalk ] with-string-writer ] unit-test
[ 5 ] [ "|x| x:=5. x" eval-smalltalk ] unit-test
[ 11 ] [ "[:i| |x| x:=5. i+x] value: 6" eval-smalltalk ] unit-test
+[ t ] [ "class Blah [method foo [5]]. Blah new foo" eval-smalltalk tuple? ] unit-test
+[ 196418 ] [ "vocab:smalltalk/eval/fib.st" eval-smalltalk-file ] unit-test
\ No newline at end of file
diff --git a/extra/smalltalk/eval/fib.st b/extra/smalltalk/eval/fib.st
new file mode 100644
index 0000000000..41ab8f56cc
--- /dev/null
+++ b/extra/smalltalk/eval/fib.st
@@ -0,0 +1,11 @@
+class Fib [
+ |i|
+ method i: newI [i:=newI].
+ method compute [
+ (i <= 1)
+ ifTrue: [^1]
+ ifFalse: [^((Fib new i:(i-1)) compute + (Fib new i:(i-2)) compute)]
+ ].
+].
+
+[(Fib new i: 26) compute] time
\ No newline at end of file
diff --git a/extra/smalltalk/parser/parser-tests.factor b/extra/smalltalk/parser/parser-tests.factor
index ff9cbc208b..9027290e6a 100644
--- a/extra/smalltalk/parser/parser-tests.factor
+++ b/extra/smalltalk/parser/parser-tests.factor
@@ -1,5 +1,6 @@
IN: smalltalk.parser.tests
-USING: smalltalk.parser smalltalk.ast peg.ebnf tools.test accessors
+USING: smalltalk.parser smalltalk.ast
+peg.ebnf tools.test accessors
io.files io.encodings.ascii kernel ;
EBNF: test-Character
@@ -296,4 +297,4 @@ test = <foreign parse-smalltalk LocalVariableDeclarationList>
[ ] [ "class Foo []. Tests blah " parse-smalltalk drop ] unit-test
-[ ] [ "vocab:smalltalk/parser/test.st" ascii file-contents parse-smalltalk drop ] unit-test
+[ ] [ "vocab:smalltalk/parser/test.st" ascii file-contents parse-smalltalk drop ] unit-test
\ No newline at end of file
diff --git a/extra/smalltalk/parser/parser.factor b/extra/smalltalk/parser/parser.factor
index 1958861606..c7cafe94dd 100644
--- a/extra/smalltalk/parser/parser.factor
+++ b/extra/smalltalk/parser/parser.factor
@@ -200,7 +200,7 @@ MethodDeclaration = OptionalWhiteSpace "method" OptionalWhiteSpace MethodHeader:
OptionalWhiteSpace "["
ExecutableCode:code
"]"
- => [[ header first2 code <ast-block> ast-method boa ]]
+ => [[ header first2 code <ast-method> ]]
ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name
OptionalWhiteSpace
From 11eff11fb753cc2b97ed73e5e1698bde60efc359 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 1 Apr 2009 02:53:30 -0500
Subject: [PATCH 42/42] Add silly optimization for 'new'; this will be removed
when compiler improves
---
extra/smalltalk/compiler/compiler.factor | 6 ++++++
1 file changed, 6 insertions(+)
diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor
index 0b6f17e3fa..2eeee30692 100644
--- a/extra/smalltalk/compiler/compiler.factor
+++ b/extra/smalltalk/compiler/compiler.factor
@@ -21,6 +21,11 @@ M: ast-name compile-ast name>> swap lookup-reader ;
: compile-arguments ( lexenv ast -- quot )
arguments>> [ compile-ast ] with map [ ] join ;
+: compile-new ( lexenv ast -- quot )
+ [ receiver>> compile-ast ]
+ [ compile-arguments ] 2bi
+ [ new ] 3append ;
+
: compile-ifTrue:ifFalse: ( lexenv ast -- quot )
[ receiver>> compile-ast ]
[ compile-arguments ] 2bi
@@ -29,6 +34,7 @@ M: ast-name compile-ast name>> swap lookup-reader ;
M: ast-message-send compile-ast
dup selector>> {
{ "ifTrue:ifFalse:" [ compile-ifTrue:ifFalse: ] }
+ { "new" [ compile-new ] }
[
drop
[ compile-arguments ]