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
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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
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 ;
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" } }
}
! 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
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 ]
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 ;
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> '[ _ ] ;
-
-: 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 ;
-
-: compile-statement ( statement -- quot )
- [ [ empty-lexenv ] dip compile-ast ] [ need-return-continuation? ] bi
- [ '[ [ [ return-continuation set @ ] callcc1 ] with-scope ] ] when ;
+ [ drop [ nil ] ] [ [ compile-ast ] with map [ drop ] join ] if-empty ;
+
+M: ast-block compile-ast
+ compile-block <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 -- 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
--- /dev/null
+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
! 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
! 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
! 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
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
: 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 ;
]
[ "[ :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
]
[ "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
! 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
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
projects / factor.git / commitdiff