Merge branch 'master' of git://69.93.127.154/git/factor into uniscribe
commit
0cfa22c276
|
@ -7,10 +7,10 @@ IN: alien.fortran
|
|||
ARTICLE: "alien.fortran-abis" "Fortran ABIs"
|
||||
"Fortran does not have a standard ABI like C does. Factor supports the following Fortran ABIs:"
|
||||
{ $list
|
||||
{ { $subsection gfortran-abi } " is used by gfortran, the Fortran compiler included with GCC 4." }
|
||||
{ { $subsection f2c-abi } " is used by the F2C Fortran-to-C translator and G77, the Fortran compiler included with GCC 3.x and earlier. It is also used by gfortran when compiling with the -ff2c flag." }
|
||||
{ { $subsection intel-unix-abi } " is used by the Intel Fortran Compiler on Linux and Mac OS X." }
|
||||
{ { $subsection intel-windows-abi } " is used by the Intel Fortran Compiler on Windows." }
|
||||
{ { $link gfortran-abi } " is used by gfortran, the Fortran compiler included with GCC 4." }
|
||||
{ { $link f2c-abi } " is used by the F2C Fortran-to-C translator and G77, the Fortran compiler included with GCC 3.x and earlier. It is also used by gfortran when compiling with the -ff2c flag." }
|
||||
{ { $link intel-unix-abi } " is used by the Intel Fortran Compiler on Linux and Mac OS X." }
|
||||
{ { $link intel-windows-abi } " is used by the Intel Fortran Compiler on Windows." }
|
||||
}
|
||||
"A library's ABI is specified when that library is opened by the " { $link add-fortran-library } " word." ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 )
|
||||
[
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
[ { 0 0 } ] [ { 3 4 } doc get doc-elt prev-elt ] unit-test
|
||||
[ { 5 10 } ] [ { 3 4 } doc get doc-elt next-elt ] unit-test
|
||||
|
|
|
@ -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 unicode.breaks combinators.short-circuit ;
|
||||
IN: documents.elements
|
||||
|
||||
GENERIC: prev-elt ( loc document elt -- newloc )
|
||||
|
@ -20,27 +20,32 @@ 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 ) -- 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-char) ;
|
||||
drop [ [ last-grapheme-from ] modify-col ] prev ;
|
||||
|
||||
M: char-elt next-elt
|
||||
drop [ drop 1 +col ] (next-char) ;
|
||||
drop [ [ first-grapheme-from ] modify-col ] next ;
|
||||
|
||||
SINGLETON: one-char-elt
|
||||
|
||||
|
@ -50,21 +55,16 @@ 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
|
||||
|
||||
: ((word-elt)) ( n seq -- n seq ? )
|
||||
: 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 )
|
||||
: next-word ( col str ? -- col )
|
||||
[ break-detector find-from drop ] [ drop length ] 2bi or ;
|
||||
|
||||
PRIVATE>
|
||||
|
@ -73,23 +73,23 @@ 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 ((word-elt)) (prev-word) ] (word-elt) ]
|
||||
(prev-char) ;
|
||||
[ [ [ 1- ] dip blank-at? prev-word ] modify-col ]
|
||||
prev ;
|
||||
|
||||
M: word-elt next-elt
|
||||
drop
|
||||
[ [ ((word-elt)) (next-word) ] (word-elt) ]
|
||||
(next-char) ;
|
||||
[ [ blank-at? next-word ] modify-col ]
|
||||
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 ;
|
||||
M: doc-elt next-elt drop nip doc-end ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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< ;
|
|
@ -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
|
||||
|
|
|
@ -0,0 +1,23 @@
|
|||
USING: alien.fortran help.markup help.syntax math.blas.config multiline ;
|
||||
IN: math.blas.config
|
||||
|
||||
ARTICLE: "math.blas.config" "Configuring the BLAS interface"
|
||||
"The " { $link "math.blas-summary" } " chooses the underlying BLAS interface to use based on the values of the following global variables:"
|
||||
{ $subsection blas-library }
|
||||
{ $subsection blas-fortran-abi }
|
||||
"The interface attempts to set default values based on the ones encountered on the Factor project's build machines. If these settings don't work with your system's BLAS, or you wish to use a commercial BLAS, you may change the global values of those variables in your " { $link "factor-rc" } ". For example, to use AMD's ACML library on Windows with " { $snippet "math.blas" } ", your " { $snippet "factor-rc" } " would look like this:"
|
||||
{ $code <"
|
||||
USING: math.blas.config namespaces ;
|
||||
"X:\\path\\to\\acml.dll" blas-library set-global
|
||||
intel-windows-abi blas-fortran-abi set-global
|
||||
"> }
|
||||
"To take effect, the " { $snippet "blas-library" } " and " { $snippet "blas-fortran-abi" } " variables must be set before any other " { $snippet "math.blas" } " vocabularies are loaded."
|
||||
;
|
||||
|
||||
HELP: blas-library
|
||||
{ $description "The name of the shared library containing the BLAS interface to load. The value of this variable must be a valid shared library name that can be passed to " { $link add-fortran-library } ". To take effect, this variable must be set before any other " { $snippet "math.blas" } " vocabularies are loaded. See " { $link "math.blas.config" } " for details and examples." } ;
|
||||
|
||||
HELP: blas-fortran-abi
|
||||
{ $description "The Fortran ABI used by the BLAS interface specified in the " { $link blas-library } " variable. The value of " { $snippet "blas-fortran-abi" } " must be one of the " { $link "alien.fortran-abis" } " that can be passed to " { $link add-fortran-library } ". To take effect, this variable must be set before any other " { $snippet "math.blas" } " vocabularies are loaded. See " { $link "math.blas.config" } " for details and examples." } ;
|
||||
|
||||
ABOUT: "math.blas.config"
|
|
@ -0,0 +1,23 @@
|
|||
USING: alien.fortran combinators kernel namespaces system ;
|
||||
IN: math.blas.config
|
||||
|
||||
SYMBOLS: blas-library blas-fortran-abi ;
|
||||
|
||||
blas-library [
|
||||
{
|
||||
{ [ os macosx? ] [ "libblas.dylib" ] }
|
||||
{ [ os windows? ] [ "blas.dll" ] }
|
||||
[ "libblas.so" ]
|
||||
} cond
|
||||
] initialize
|
||||
|
||||
blas-fortran-abi [
|
||||
{
|
||||
{ [ os macosx? ] [ intel-unix-abi ] }
|
||||
{ [ os windows? cpu x86.32? and ] [ f2c-abi ] }
|
||||
{ [ os windows? cpu x86.64? and ] [ gfortran-abi ] }
|
||||
{ [ os freebsd? ] [ gfortran-abi ] }
|
||||
{ [ os linux? cpu x86.32? and ] [ gfortran-abi ] }
|
||||
[ f2c-abi ]
|
||||
} cond
|
||||
] initialize
|
|
@ -1,19 +1,9 @@
|
|||
USING: alien alien.fortran kernel system combinators
|
||||
alien.libraries ;
|
||||
USING: alien.fortran kernel math.blas.config namespaces ;
|
||||
IN: math.blas.ffi
|
||||
|
||||
<<
|
||||
"blas" {
|
||||
{ [ os macosx? ] [ "libblas.dylib" intel-unix-abi add-fortran-library ] }
|
||||
{ [ os windows? cpu x86.32? and ] [ "blas.dll" f2c-abi add-fortran-library ] }
|
||||
{ [ os windows? cpu x86.64? and ] [ "blas.dll" gfortran-abi add-fortran-library ] }
|
||||
{
|
||||
[ os [ freebsd? ] [ linux? cpu x86.32? and ] bi or ]
|
||||
[ "libblas.so" gfortran-abi add-fortran-library ]
|
||||
}
|
||||
{ [ os [ freebsd? ] [ linux? ] bi or ] [ "libblas.so" gfortran-abi add-fortran-library ] }
|
||||
[ "libblas.so" f2c-abi add-fortran-library ]
|
||||
} cond
|
||||
"blas" blas-library blas-fortran-abi [ get ] bi@
|
||||
add-fortran-library
|
||||
>>
|
||||
|
||||
LIBRARY: blas
|
||||
|
|
|
@ -2,13 +2,14 @@ USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequence
|
|||
IN: math.blas.matrices
|
||||
|
||||
ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface"
|
||||
"Factor provides an interface to high-performance vector and matrix math routines available in the system's BLAS library. A set of specialized types are provided for handling packed, unboxed vector data:"
|
||||
"Factor provides an interface to high-performance vector and matrix math routines available in implementations of the BLAS math library. A set of specialized types are provided for handling packed, unboxed vector data:"
|
||||
{ $subsection "math.blas-types" }
|
||||
"Scalar-vector and vector-vector operations are available in the " { $vocab-link "math.blas.vectors" } " vocabulary:"
|
||||
{ $subsection "math.blas.vectors" }
|
||||
"Vector-matrix and matrix-matrix operations are available in the " { $vocab-link "math.blas.matrices" } " vocabulary:"
|
||||
{ $subsection "math.blas.matrices" }
|
||||
"The low-level BLAS Fortran interface can be accessed directly through the " { $vocab-link "math.blas.ffi" } " vocabulary." ;
|
||||
"The low-level BLAS Fortran interface can be accessed directly through the " { $vocab-link "math.blas.ffi" } " vocabulary. The BLAS interface can be configured to use different underlying BLAS implementations:"
|
||||
{ $subsection "math.blas.config" } ;
|
||||
|
||||
ARTICLE: "math.blas-types" "BLAS interface types"
|
||||
"BLAS vectors come in single- and double-precision, real and complex flavors:"
|
||||
|
|
|
@ -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>
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
|
@ -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 )
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 { "seq" "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 }
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ( seq -- 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
|
||||
|
||||
|
|
|
@ -157,6 +157,7 @@ IN: tools.deploy.shaker
|
|||
"specializer"
|
||||
"step-into"
|
||||
"step-into?"
|
||||
"superclass"
|
||||
"transform-n"
|
||||
"transform-quot"
|
||||
"tuple-dispatch-generic"
|
||||
|
|
|
@ -75,7 +75,8 @@ M: pane gadget-selection ( pane -- string/f )
|
|||
GENERIC: draw-selection ( loc obj -- )
|
||||
|
||||
: if-fits ( rect quot -- )
|
||||
[ clip get over contains-rect? ] dip [ drop ] if ; inline
|
||||
[ clip get origin get vneg offset-rect over contains-rect? ] dip
|
||||
[ drop ] if ; inline
|
||||
|
||||
M: gadget draw-selection ( loc gadget -- )
|
||||
swap offset-rect [
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
] 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
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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" ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -65,9 +65,8 @@ HELP: derive-url
|
|||
} ;
|
||||
|
||||
HELP: ensure-port
|
||||
{ $values { "url" url } }
|
||||
{ $description "If the URL does not specify a port number, fill in the default for the URL's protocol. If the protocol is unknown, the port number is not changed." }
|
||||
{ $side-effects "url" }
|
||||
{ $values { "url" url } { "url'" url } }
|
||||
{ $description "If the URL does not specify a port number, create a new URL which is equal except the port number is set to the default for the URL's protocol. If the protocol is unknown, outputs an exact copy of the input URL." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: accessors prettyprint urls ;"
|
||||
|
|
|
@ -175,8 +175,8 @@ PRIVATE>
|
|||
] [ protocol>> ] bi
|
||||
secure-protocol? [ >secure-addr ] when ;
|
||||
|
||||
: ensure-port ( url -- url )
|
||||
dup protocol>> '[ _ protocol-port or ] change-port ;
|
||||
: ensure-port ( url -- url' )
|
||||
clone dup protocol>> '[ _ protocol-port or ] change-port ;
|
||||
|
||||
! Literal syntax
|
||||
SYNTAX: URL" lexer get skip-blank parse-string >url parsed ;
|
||||
|
|
|
@ -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 ;
|
||||
[ ")" parse-effect ] dip 2array over push-all ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
|
@ -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 ] [
|
||||
|
|
|
@ -59,11 +59,11 @@ C: <transaction> transaction
|
|||
[ dup [ over [ swap call ] dip ] dip 1 days time+ ] dip each-day
|
||||
] [
|
||||
3drop
|
||||
] if ;
|
||||
] 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 ;
|
||||
|
|
|
@ -0,0 +1,12 @@
|
|||
USING: tools.deploy.config ;
|
||||
V{
|
||||
{ deploy-ui? t }
|
||||
{ deploy-io 1 }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-math? t }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-c-types? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-name "Chicago Talk" }
|
||||
}
|
|
@ -0,0 +1 @@
|
|||
Slides for a talk at the Pycon VM Summit, Chicago, IL, March 2009
|
|
@ -0,0 +1 @@
|
|||
demos
|
|
@ -3,7 +3,7 @@
|
|||
USING: assocs html.parser kernel math sequences strings ascii
|
||||
arrays generalizations shuffle unicode.case namespaces make
|
||||
splitting http accessors io combinators http.client urls
|
||||
urls.encoding fry prettyprint ;
|
||||
urls.encoding fry prettyprint sets ;
|
||||
IN: html.parser.analyzer
|
||||
|
||||
TUPLE: link attributes clickable ;
|
||||
|
@ -126,7 +126,15 @@ TUPLE: link attributes clickable ;
|
|||
[ [
|
||||
[ name>> "a" = ]
|
||||
[ attributes>> "href" swap key? ] bi and ] filter
|
||||
] map sift [ [ attributes>> "href" swap at ] map ] map concat ;
|
||||
] map sift
|
||||
[ [ attributes>> "href" swap at ] map ] map concat ;
|
||||
|
||||
: find-frame-links ( vector -- vector' )
|
||||
[ name>> "frame" = ] find-between-all
|
||||
[ [ attributes>> "src" swap at ] map sift ] map concat sift ;
|
||||
|
||||
: find-all-links ( vector -- vector' )
|
||||
[ find-hrefs ] [ find-frame-links ] bi append prune ;
|
||||
|
||||
: find-forms ( vector -- vector' )
|
||||
"form" over find-opening-tags-by-name
|
||||
|
|
|
@ -42,6 +42,19 @@ V{
|
|||
}
|
||||
] [ "<a href = \"http://factorcode.org/\" foo = bar baz='quux'a=pirsqd >" parse-html ] unit-test
|
||||
|
||||
[
|
||||
V{
|
||||
T{ tag f "a"
|
||||
H{
|
||||
{ "a" "pirsqd" }
|
||||
{ "foo" "bar" }
|
||||
{ "href" "http://factorcode.org/" }
|
||||
{ "baz" "quux" }
|
||||
{ "nofollow" "nofollow" }
|
||||
} f f }
|
||||
}
|
||||
] [ "<a href = \"http://factorcode.org/\" nofollow foo = bar baz='quux'a=pirsqd >" parse-html ] unit-test
|
||||
|
||||
[
|
||||
V{
|
||||
T{ tag f "html" H{ } f f }
|
||||
|
|
|
@ -1,8 +1,9 @@
|
|||
! 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 namespaces sequences
|
||||
unicode.case unicode.categories combinators.short-circuit
|
||||
quoting fry ;
|
||||
IN: html.parser
|
||||
|
||||
TUPLE: tag name attributes text closing? ;
|
||||
|
@ -10,6 +11,9 @@ TUPLE: tag name attributes text closing? ;
|
|||
SINGLETON: text
|
||||
SINGLETON: dtd
|
||||
SINGLETON: comment
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: tagstack
|
||||
|
||||
: push-tag ( tag -- )
|
||||
|
@ -17,7 +21,7 @@ SYMBOL: tagstack
|
|||
|
||||
: closing-tag? ( string -- ? )
|
||||
[ f ]
|
||||
[ [ first ] [ peek ] bi [ CHAR: / = ] bi@ or ] if-empty ;
|
||||
[ { [ first CHAR: / = ] [ peek CHAR: / = ] } 1|| ] if-empty ;
|
||||
|
||||
: <tag> ( name attributes closing? -- tag )
|
||||
tag new
|
||||
|
@ -28,116 +32,96 @@ SYMBOL: tagstack
|
|||
: make-tag ( string attribs -- tag )
|
||||
[ [ closing-tag? ] keep "/" trim1 ] dip rot <tag> ;
|
||||
|
||||
: make-text-tag ( string -- tag )
|
||||
: new-tag ( text name -- tag )
|
||||
tag new
|
||||
text >>name
|
||||
swap >>text ;
|
||||
swap >>name
|
||||
swap >>text ; inline
|
||||
|
||||
: make-comment-tag ( string -- tag )
|
||||
tag new
|
||||
comment >>name
|
||||
swap >>text ;
|
||||
: (read-quote) ( state-parser ch -- string )
|
||||
'[ [ current _ = ] take-until ] [ advance drop ] bi ;
|
||||
|
||||
: make-dtd-tag ( string -- tag )
|
||||
tag new
|
||||
dtd >>name
|
||||
swap >>text ;
|
||||
: read-single-quote ( state-parser -- string )
|
||||
CHAR: ' (read-quote) ;
|
||||
|
||||
: read-whitespace ( -- string )
|
||||
[ get-char blank? not ] take-until ;
|
||||
: read-double-quote ( state-parser -- string )
|
||||
CHAR: " (read-quote) ;
|
||||
|
||||
: read-whitespace* ( -- ) read-whitespace drop ;
|
||||
: read-quote ( state-parser -- string )
|
||||
dup get+increment CHAR: ' =
|
||||
[ read-single-quote ] [ read-double-quote ] if ;
|
||||
|
||||
: read-token ( -- string )
|
||||
read-whitespace*
|
||||
[ get-char blank? ] take-until ;
|
||||
: read-key ( state-parser -- string )
|
||||
skip-whitespace
|
||||
[ current { [ CHAR: = = ] [ blank? ] } 1|| ] take-until ;
|
||||
|
||||
: read-single-quote ( -- string )
|
||||
[ get-char CHAR: ' = ] take-until ;
|
||||
: read-token ( state-parser -- string )
|
||||
[ current blank? ] take-until ;
|
||||
|
||||
: read-double-quote ( -- string )
|
||||
[ get-char CHAR: " = ] take-until ;
|
||||
|
||||
: read-quote ( -- string )
|
||||
get-char next CHAR: ' =
|
||||
[ read-single-quote ] [ read-double-quote ] if next ;
|
||||
|
||||
: read-key ( -- string )
|
||||
read-whitespace*
|
||||
[ get-char [ CHAR: = = ] [ blank? ] bi or ] 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 current quote? [ read-quote ] [ read-token ] if
|
||||
[ blank? ] trim ;
|
||||
|
||||
: read-comment ( -- )
|
||||
"-->" take-string make-comment-tag push-tag ;
|
||||
: read-comment ( state-parser -- )
|
||||
"-->" take-until-sequence comment new-tag push-tag ;
|
||||
|
||||
: read-dtd ( -- )
|
||||
">" take-string make-dtd-tag push-tag ;
|
||||
: read-dtd ( state-parser -- )
|
||||
">" take-until-sequence dtd new-tag push-tag ;
|
||||
|
||||
: read-bang ( -- )
|
||||
next get-char CHAR: - = get-next CHAR: - = and [
|
||||
next next
|
||||
read-comment
|
||||
: read-bang ( state-parser -- )
|
||||
advance dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&&
|
||||
[ advance advance read-comment ] [ read-dtd ] if ;
|
||||
|
||||
: read-tag ( state-parser -- string )
|
||||
[ [ current "><" member? ] take-until ]
|
||||
[ dup current CHAR: < = [ advance ] unless drop ] bi ;
|
||||
|
||||
: read-until-< ( state-parser -- string )
|
||||
[ current CHAR: < = ] take-until ;
|
||||
|
||||
: parse-text ( state-parser -- )
|
||||
read-until-< [ text new-tag push-tag ] unless-empty ;
|
||||
|
||||
: parse-key/value ( state-parser -- key value )
|
||||
[ read-key >lower ]
|
||||
[ skip-whitespace "=" take-sequence ]
|
||||
[ swap [ read-value ] [ drop dup ] if ] tri ;
|
||||
|
||||
: (parse-attributes) ( state-parser -- )
|
||||
skip-whitespace
|
||||
dup state-parse-end? [
|
||||
drop
|
||||
] [
|
||||
read-dtd
|
||||
[ parse-key/value swap set ] [ (parse-attributes) ] bi
|
||||
] if ;
|
||||
|
||||
: read-tag ( -- string )
|
||||
[ get-char CHAR: > = get-char CHAR: < = or ] take-until
|
||||
get-char CHAR: < = [ next ] unless ;
|
||||
|
||||
: read-< ( -- string )
|
||||
next get-char CHAR: ! = [
|
||||
read-bang f
|
||||
] [
|
||||
read-tag
|
||||
] 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) ] { } make >hashtable ;
|
||||
: parse-attributes ( state-parser -- hashtable )
|
||||
[ (parse-attributes) ] H{ } make-assoc ;
|
||||
|
||||
: (parse-tag) ( string -- string' hashtable )
|
||||
[
|
||||
read-token >lower
|
||||
parse-attributes
|
||||
] string-parse ;
|
||||
[ read-token >lower ] [ parse-attributes ] bi
|
||||
] state-parse ;
|
||||
|
||||
: parse-tag ( -- )
|
||||
read-< [
|
||||
(parse-tag) make-tag push-tag
|
||||
] unless-empty ;
|
||||
: read-< ( state-parser -- string/f )
|
||||
advance dup current [
|
||||
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 peek-next [
|
||||
[ parse-text ] [ parse-tag ] [ (parse-html) ] tri
|
||||
] [ drop ] if ;
|
||||
|
||||
: tag-parse ( quot -- vector )
|
||||
V{ } clone tagstack [ string-parse ] with-variable ; inline
|
||||
V{ } clone tagstack [ state-parse ] with-variable ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: parse-html ( string -- vector )
|
||||
[ (parse-html) tagstack get ] tag-parse ;
|
||||
|
|
|
@ -1,14 +1,95 @@
|
|||
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 ] state-parse ] unit-test
|
||||
|
||||
: take-char ( -- string )
|
||||
[ get-char = ] curry take-until ;
|
||||
[ "hi" " how are you?" ]
|
||||
[
|
||||
"hi how are you?"
|
||||
[ [ [ current blank? ] take-until ] [ take-rest ] bi ] state-parse
|
||||
] unit-test
|
||||
|
||||
[ "foo" ";bar" ]
|
||||
[
|
||||
"foo;bar" [
|
||||
[ CHAR: ; take-until-object ] [ take-rest ] bi
|
||||
] state-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-sequence ] [ take-rest ] bi
|
||||
] state-parse
|
||||
] unit-test
|
||||
|
||||
[ 6 ]
|
||||
[
|
||||
" foo " [ skip-whitespace n>> ] state-parse
|
||||
] unit-test
|
||||
|
||||
[ { 1 2 } ]
|
||||
[ { 1 2 3 } <state-parser> [ current 3 = ] take-until ] unit-test
|
||||
|
||||
[ { 1 2 } ]
|
||||
[ { 1 2 3 4 } <state-parser> { 3 4 } take-until-sequence ] unit-test
|
||||
|
||||
[ "ab" ]
|
||||
[ "abcd" <state-parser> "ab" take-sequence ] unit-test
|
||||
|
||||
[ f ]
|
||||
[ "abcd" <state-parser> "lol" take-sequence ] unit-test
|
||||
|
||||
[ "ab" ]
|
||||
[
|
||||
"abcd" <state-parser>
|
||||
[ "lol" take-sequence drop ] [ "ab" take-sequence ] bi
|
||||
] unit-test
|
||||
|
||||
[ "" ]
|
||||
[ "abcd" <state-parser> "" take-sequence ] unit-test
|
||||
|
||||
[ "cd" ]
|
||||
[ "abcd" <state-parser> [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test
|
||||
|
||||
[ f ]
|
||||
[
|
||||
"\"abc\" asdf" <state-parser>
|
||||
[ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi
|
||||
] unit-test
|
||||
|
||||
[ "abc\\\"def" ]
|
||||
[
|
||||
"\"abc\\\"def\" asdf" <state-parser>
|
||||
CHAR: \ CHAR: " take-quoted-string
|
||||
] unit-test
|
||||
|
||||
[ "asdf" ]
|
||||
[
|
||||
"\"abc\" asdf" <state-parser>
|
||||
[ CHAR: \ CHAR: " take-quoted-string drop ]
|
||||
[ skip-whitespace "asdf" take-sequence ] bi
|
||||
] unit-test
|
||||
|
||||
[ f ]
|
||||
[
|
||||
"\"abc asdf" <state-parser>
|
||||
CHAR: \ CHAR: " take-quoted-string
|
||||
] unit-test
|
||||
|
||||
[ "\"abc" ]
|
||||
[
|
||||
"\"abc asdf" <state-parser>
|
||||
[ CHAR: \ CHAR: " take-quoted-string drop ]
|
||||
[ "\"abc" take-sequence ] bi
|
||||
] unit-test
|
||||
|
||||
[ "c" ]
|
||||
[ "c" <state-parser> take-token ] unit-test
|
||||
|
||||
[ f ]
|
||||
[ "" <state-parser> take-token ] unit-test
|
||||
|
||||
[ "abcd e \\\"f g" ]
|
||||
[ "\"abcd e \\\"f g\"" <state-parser> CHAR: \ CHAR: " take-token* ] unit-test
|
||||
|
|
|
@ -1,41 +1,113 @@
|
|||
! 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 combinators.short-circuit
|
||||
make combinators ;
|
||||
|
||||
IN: html.parser.state
|
||||
|
||||
TUPLE: state string i ;
|
||||
TUPLE: state-parser sequence n ;
|
||||
|
||||
: get-i ( -- i ) state get i>> ; inline
|
||||
: <state-parser> ( sequence -- state-parser )
|
||||
state-parser new
|
||||
swap >>sequence
|
||||
0 >>n ;
|
||||
|
||||
: get-char ( -- char )
|
||||
state get [ i>> ] [ string>> ] bi ?nth ; inline
|
||||
: offset ( state-parser offset -- char/f )
|
||||
swap
|
||||
[ n>> + ] [ sequence>> ?nth ] bi ; inline
|
||||
|
||||
: get-next ( -- char )
|
||||
state get [ i>> 1+ ] [ string>> ] bi ?nth ; inline
|
||||
: current ( state-parser -- char/f ) 0 offset ; inline
|
||||
|
||||
: next ( -- )
|
||||
state get [ 1+ ] change-i drop ; inline
|
||||
: previous ( state-parser -- char/f ) -1 offset ; inline
|
||||
|
||||
: string-parse ( string quot -- )
|
||||
[ 0 state boa state ] dip with-variable ; inline
|
||||
: peek-next ( state-parser -- char/f ) 1 offset ; inline
|
||||
|
||||
: short* ( n seq -- n' seq )
|
||||
over [ nip dup length swap ] unless ; inline
|
||||
: advance ( state-parser -- state-parser )
|
||||
[ 1 + ] change-n ; inline
|
||||
|
||||
: skip-until ( quot: ( -- ? ) -- )
|
||||
get-char [
|
||||
[ call ] keep swap
|
||||
[ drop ] [ next skip-until ] if
|
||||
] [ drop ] if ; inline recursive
|
||||
: advance* ( state-parser -- )
|
||||
advance drop ; inline
|
||||
|
||||
: take-until ( quot: ( -- ? ) -- )
|
||||
get-i [ skip-until ] dip get-i
|
||||
state get string>> subseq ; inline
|
||||
: get+increment ( state-parser -- char/f )
|
||||
[ current ] [ advance drop ] bi ; inline
|
||||
|
||||
: string-matches? ( string circular -- ? )
|
||||
get-char over push-growing-circular sequence= ; inline
|
||||
:: skip-until ( state-parser quot: ( obj -- ? ) -- )
|
||||
state-parser current [
|
||||
state-parser quot call [ state-parser advance quot skip-until ] unless
|
||||
] when ; inline recursive
|
||||
|
||||
: take-string ( match -- string )
|
||||
dup length <growing-circular>
|
||||
[ 2dup string-matches? ] take-until nip
|
||||
dup length rot length 1- - head next ; inline
|
||||
: state-parse-end? ( state-parser -- ? ) current not ;
|
||||
|
||||
: take-until ( state-parser quot: ( obj -- ? ) -- sequence/f )
|
||||
over state-parse-end? [
|
||||
2drop f
|
||||
] [
|
||||
[ drop n>> ]
|
||||
[ skip-until ]
|
||||
[ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq
|
||||
] if ; inline
|
||||
|
||||
: take-while ( state-parser quot: ( obj -- ? ) -- sequence/f )
|
||||
[ not ] compose take-until ; inline
|
||||
|
||||
:: take-sequence ( state-parser sequence -- obj/f )
|
||||
state-parser [ n>> dup sequence length + ] [ sequence>> ] bi <slice>
|
||||
sequence sequence= [
|
||||
sequence
|
||||
state-parser [ sequence length + ] change-n drop
|
||||
] [
|
||||
f
|
||||
] if ;
|
||||
|
||||
:: take-until-sequence ( state-parser sequence -- sequence' )
|
||||
sequence length <growing-circular> :> growing
|
||||
state-parser
|
||||
[
|
||||
current growing push-growing-circular
|
||||
sequence growing sequence=
|
||||
] take-until :> found
|
||||
found dup length
|
||||
growing length 1- - head
|
||||
state-parser advance drop ;
|
||||
|
||||
: skip-whitespace ( state-parser -- state-parser )
|
||||
[ [ current blank? not ] take-until drop ] keep ;
|
||||
|
||||
: take-rest ( state-parser -- sequence )
|
||||
[ drop f ] take-until ; inline
|
||||
|
||||
: take-until-object ( state-parser obj -- sequence )
|
||||
'[ current _ = ] take-until ;
|
||||
|
||||
: state-parse ( sequence quot -- )
|
||||
[ <state-parser> ] dip call ; inline
|
||||
|
||||
:: take-quoted-string ( state-parser escape-char quote-char -- string )
|
||||
state-parser n>> :> start-n
|
||||
state-parser advance
|
||||
[
|
||||
{
|
||||
[ { [ previous escape-char = ] [ current quote-char = ] } 1&& ]
|
||||
[ current quote-char = not ]
|
||||
} 1||
|
||||
] take-while :> string
|
||||
state-parser current quote-char = [
|
||||
state-parser advance* string
|
||||
] [
|
||||
start-n state-parser (>>n) f
|
||||
] if ;
|
||||
|
||||
: (take-token) ( state-parser -- string )
|
||||
skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ;
|
||||
|
||||
:: take-token* ( state-parser escape-char quote-char -- string/f )
|
||||
state-parser skip-whitespace
|
||||
dup current {
|
||||
{ quote-char [ escape-char quote-char take-quoted-string ] }
|
||||
{ f [ drop f ] }
|
||||
[ drop (take-token) ]
|
||||
} case ;
|
||||
|
||||
: take-token ( state-parser -- string/f )
|
||||
CHAR: \ CHAR: " take-token* ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -8,5 +8,5 @@ V{
|
|||
{ deploy-word-props? f }
|
||||
{ deploy-c-types? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-name "Catalyst Talk" }
|
||||
{ deploy-name "Minnesota Talk" }
|
||||
}
|
||||
|
|
|
@ -1 +1 @@
|
|||
Slides for a talk at Ruby.mn, Minneapolis MN, January 2008
|
||||
Slides for a talk at Ruby.mn, Minneapolis, MN, January 2008
|
||||
|
|
|
@ -0,0 +1,53 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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 } { 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 } ;
|
||||
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: ast-foreign { class string } { name string } ;
|
||||
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 ]
|
||||
[ 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 ;
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -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
|
|
@ -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 ;
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -0,0 +1,87 @@
|
|||
USING: smalltalk.compiler tools.test prettyprint smalltalk.ast
|
||||
smalltalk.compiler.lexenv stack-checker locals.rewrite.closures
|
||||
kernel accessors compiler.units sequences arrays ;
|
||||
IN: smalltalk.compiler.tests
|
||||
|
||||
: test-compilation ( ast -- quot )
|
||||
[
|
||||
1array ast-sequence new swap >>body
|
||||
compile-smalltalk [ call ] append
|
||||
] 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" } }
|
||||
}
|
||||
}
|
||||
} 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 "c" }
|
||||
"+"
|
||||
{ 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" } }
|
||||
}
|
||||
} 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
|
|
@ -0,0 +1,157 @@
|
|||
! 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
|
||||
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
|
||||
|
||||
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 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
|
||||
[ if ] 3append ;
|
||||
|
||||
M: ast-message-send compile-ast
|
||||
dup selector>> {
|
||||
{ "ifTrue:ifFalse:" [ compile-ifTrue:ifFalse: ] }
|
||||
{ "new" [ compile-new ] }
|
||||
[
|
||||
drop
|
||||
[ compile-arguments ]
|
||||
[ receiver>> compile-ast ]
|
||||
[ nip selector>> selector>generic ]
|
||||
2tri [ append ] dip suffix
|
||||
]
|
||||
} case ;
|
||||
|
||||
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 ] [ drop return>> 1quotation ] 2bi
|
||||
[ continue-with ] 3append ;
|
||||
|
||||
: (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
|
||||
compile-sequence nip ;
|
||||
|
||||
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 name>> swap lookup-writer ;
|
||||
|
||||
M: ast-assignment compile-ast
|
||||
[ value>> compile-ast [ dup ] ] [ name>> compile-assignment ] 2bi 3append ;
|
||||
|
||||
M: ast-block compile-ast
|
||||
compile-sequence <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 ] 2keep
|
||||
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> >>self "^" <local> >>return ;
|
||||
|
||||
M: ast-class compile-ast
|
||||
nip
|
||||
[
|
||||
[ name>> ] [ superclass>> ] [ ivars>> ] tri
|
||||
define-class <class-lexenv>
|
||||
]
|
||||
[ methods>> ] bi
|
||||
[ compile-method ] with each
|
||||
[ nil ] ;
|
||||
|
||||
ERROR: no-word name ;
|
||||
|
||||
M: ast-foreign compile-ast
|
||||
nip
|
||||
[ class>> dup ":" split1 lookup [ ] [ no-word ] ?if ]
|
||||
[ name>> ] bi define-foreign
|
||||
[ nil ] ;
|
||||
|
||||
: compile-smalltalk ( statement -- quot )
|
||||
[ empty-lexenv ] dip [ compile-sequence nip 0 ]
|
||||
2keep make-return ;
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -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
|
|
@ -0,0 +1,67 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs kernel accessors quotations slots words
|
||||
sequences namespaces combinators combinators.short-circuit
|
||||
summary smalltalk.classes ;
|
||||
IN: smalltalk.compiler.lexenv
|
||||
|
||||
! 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 return class method ;
|
||||
|
||||
: <lexenv> ( -- lexenv ) lexenv new ; inline
|
||||
|
||||
CONSTANT: empty-lexenv T{ lexenv }
|
||||
|
||||
: lexenv-union ( lexenv1 lexenv2 -- lexenv )
|
||||
[ <lexenv> ] 2dip {
|
||||
[ [ 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 ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
M: bad-identifier summary drop "Unknown identifier" ;
|
||||
|
||||
: 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|| ;
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -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
|
|
@ -0,0 +1,45 @@
|
|||
! 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 locals.types locals.rewrite.closures
|
||||
namespaces make 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 lexenv block -- quot )
|
||||
block need-return-continuation? [
|
||||
quot clone [ lexenv return>> <def> '[ _ ] prepend ] change-body
|
||||
n '[ _ _ ncurry callcc1 ]
|
||||
] [ quot ] if rewrite-closures first ;
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -0,0 +1,11 @@
|
|||
IN: smalltalk.eval.tests
|
||||
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 ] [ "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
|
||||
[ 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
|
|
@ -0,0 +1,13 @@
|
|||
! 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
|
||||
smalltalk.library ;
|
||||
IN: smalltalk.eval
|
||||
|
||||
: eval-smalltalk ( string -- result )
|
||||
[ parse-smalltalk compile-smalltalk ] with-compilation-unit
|
||||
call( -- result ) ;
|
||||
|
||||
: eval-smalltalk-file ( path -- result )
|
||||
utf8 file-contents eval-smalltalk ;
|
|
@ -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
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -0,0 +1,101 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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
|
||||
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: *
|
||||
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 = ;
|
||||
|
||||
SELECTOR: min:
|
||||
SELECTOR: max:
|
||||
|
||||
M: object selector-min: min ;
|
||||
M: object selector-max: max ;
|
||||
|
||||
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: isNil
|
||||
|
||||
M: object selector-isNil nil eq? ;
|
||||
|
||||
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 ) ;
|
||||
|
||||
SELECTOR: new
|
||||
|
||||
M: object selector-new new ;
|
||||
|
||||
SELECTOR: time
|
||||
|
||||
M: object selector-time '[ _ call( -- result ) ] time ;
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -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.eval smalltalk.printer smalltalk.listener ;
|
||||
IN: smalltalk.listener
|
||||
|
||||
: 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-interactively smalltalk-listener ] when* ;
|
||||
|
||||
MAIN: smalltalk-listener
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -0,0 +1,300 @@
|
|||
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
|
||||
|
||||
[
|
||||
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
|
||||
|
||||
[
|
||||
T{ ast-block
|
||||
{ body { 5 self } }
|
||||
}
|
||||
]
|
||||
[ "[5. 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 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
|
||||
T{ ast-message-send f 3 "factorial" { } }
|
||||
"+"
|
||||
{ 4 }
|
||||
}
|
||||
"factorial"
|
||||
{ }
|
||||
}
|
||||
]
|
||||
[ "(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-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-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 } }
|
||||
"*"
|
||||
{ 3 }
|
||||
}
|
||||
]
|
||||
[ "1+2*3" 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-name f "value" } ] [ "value" test-FinalStatement ] unit-test
|
||||
[ T{ ast-return f T{ ast-name f "value" } } ] [ "^value" 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>
|
||||
;EBNF
|
||||
|
||||
[ T{ ast-local-variables f { "i" "j" } } ] [ " | i j |" test-LocalVariableDeclarationList ] unit-test
|
||||
|
||||
|
||||
[ T{ ast-message-send f T{ ast-name f "x" } "foo:bar:" { 1 2 } } ]
|
||||
[ "x foo:1 bar:2" test-Expression ] 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-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 { }
|
||||
{
|
||||
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
|
||||
|
||||
[ ] [ "class Foo []. Tests blah " parse-smalltalk drop ] unit-test
|
||||
|
||||
[ ] [ "vocab:smalltalk/parser/test.st" ascii file-contents parse-smalltalk drop ] unit-test
|
|
@ -0,0 +1,228 @@
|
|||
! 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 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 ;
|
||||
|
||||
: 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
|
||||
"]" => [[ args >array body <ast-block> ]]
|
||||
|
||||
Literal = (ConstantReference
|
||||
| FloatingPointLiteral
|
||||
| IntegerLiteral
|
||||
| CharacterLiteral
|
||||
| StringLiteral
|
||||
| ArrayLiteral
|
||||
| SymbolLiteral
|
||||
| BlockLiteral)
|
||||
|
||||
NestedExpression = "(" Statement:s OptionalWhiteSpace ")" => [[ s ]]
|
||||
Operand = Literal
|
||||
| PseudoVariableReference
|
||||
| Reference
|
||||
| NestedExpression
|
||||
|
||||
UnaryMessage = OptionalWhiteSpace
|
||||
UnaryMessageSelector:s !(":")
|
||||
=> [[ s { } ast-message boa ]]
|
||||
|
||||
BinaryMessage = OptionalWhiteSpace
|
||||
BinaryMessageSelector:selector
|
||||
OptionalWhiteSpace
|
||||
(UnaryMessageSend | Operand):rhs
|
||||
=> [[ selector { rhs } ast-message boa ]]
|
||||
|
||||
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 ]]
|
||||
|
||||
Message = BinaryMessage | UnaryMessage | KeywordMessage
|
||||
|
||||
UnaryMessageSend = (UnaryMessageSend | Operand):lhs
|
||||
UnaryMessage:h
|
||||
(OptionalWhiteSpace ";" Message:m => [[ m ]])*:t
|
||||
=> [[ lhs t h prefix >array <ast-cascade> ]]
|
||||
|
||||
BinaryMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):lhs
|
||||
BinaryMessage: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> ]]
|
||||
|
||||
Expression = OptionalWhiteSpace
|
||||
(KeywordMessageSend | BinaryMessageSend | UnaryMessageSend | Operand):e
|
||||
=> [[ e ]]
|
||||
|
||||
AssignmentOperation = OptionalWhiteSpace BindableIdentifier:i
|
||||
OptionalWhiteSpace ":=" OptionalWhiteSpace => [[ i ast-name boa ]]
|
||||
AssignmentStatement = AssignmentOperation:a Statement:s => [[ a s ast-assignment boa ]]
|
||||
Statement = ClassDeclaration | ForeignClassDeclaration | AssignmentStatement | Expression
|
||||
|
||||
MethodReturnOperator = OptionalWhiteSpace "^"
|
||||
FinalStatement = (MethodReturnOperator Statement:s => [[ s ast-return boa ]])
|
||||
| Statement
|
||||
|
||||
LocalVariableDeclarationList = OptionalWhiteSpace "|" OptionalWhiteSpace
|
||||
(BindableIdentifier:h
|
||||
(Whitespace BindableIdentifier:b => [[ b ]])*:t
|
||||
=> [[ t h prefix ]]
|
||||
)?:b OptionalWhiteSpace "|" => [[ b >array ast-local-variables boa ]]
|
||||
|
||||
EndStatement = "."
|
||||
|
||||
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 { } } ]]
|
||||
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
|
||||
"]"
|
||||
=> [[ header first2 code <ast-method> ]]
|
||||
|
||||
ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name
|
||||
OptionalWhiteSpace
|
||||
("extends" OptionalWhiteSpace Identifier:superclass OptionalWhiteSpace => [[ superclass ]])?:superclass
|
||||
OptionalWhiteSpace "["
|
||||
(OptionalWhiteSpace LocalVariableDeclarationList:l => [[ l names>> ]])?:ivars
|
||||
(MethodDeclaration:h
|
||||
(OptionalWhiteSpace
|
||||
EndStatement
|
||||
OptionalWhiteSpace
|
||||
MethodDeclaration:m => [[ m ]])*:t (EndStatement)?
|
||||
=> [[ t h prefix ]]
|
||||
)?:methods
|
||||
OptionalWhiteSpace "]"
|
||||
=> [[ 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 = TopLevelForm End
|
||||
|
||||
;EBNF
|
|
@ -0,0 +1,65 @@
|
|||
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
|
||||
].
|
||||
|
||||
method binarytrees: arg [
|
||||
self binarytrees: 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
|
||||
]
|
||||
].
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -0,0 +1,4 @@
|
|||
IN: smalltalk.printer.tests
|
||||
USING: smalltalk.printer tools.test ;
|
||||
|
||||
[ "#((1 2) 'hi')" ] [ { { 1 2 } "hi" } smalltalk>string ] unit-test
|
|
@ -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
|
||||
[ array-element>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 ;
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -0,0 +1,28 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators effects generic generic.standard
|
||||
kernel sequences words lexer ;
|
||||
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 ;
|
||||
|
||||
SYNTAX: SELECTOR: scan selector>generic drop ;
|
|
@ -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> "> }
|
||||
|
|
|
@ -3,22 +3,51 @@
|
|||
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
|
||||
present ;
|
||||
IN: spider
|
||||
|
||||
TUPLE: spider base count max-count sleep max-depth initial-links
|
||||
filters spidered todo nonmatching quiet ;
|
||||
filters spidered todo nonmatching quiet currently-spidering ;
|
||||
|
||||
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 ;
|
||||
|
||||
: url-exists? ( url unique-deque -- ? )
|
||||
[ url>> ] [ assoc>> ] bi* key? ;
|
||||
|
||||
: push-url ( url depth unique-deque -- )
|
||||
[ <todo-url> ] dip 2dup url-exists? [
|
||||
2drop
|
||||
] [
|
||||
[ [ [ t ] dip url>> ] [ assoc>> ] bi* set-at ]
|
||||
[ deque>> push-back ] 2bi
|
||||
] if ;
|
||||
|
||||
: 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
|
||||
over >>currently-spidering
|
||||
swap 0 <unique-deque> [ push-url ] keep >>todo
|
||||
<unique-deque> >>nonmatching
|
||||
0 >>max-depth
|
||||
0 >>count
|
||||
1/0. >>max-count
|
||||
|
@ -27,10 +56,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 -- )
|
||||
'[ _ _ push-url ] each ;
|
||||
|
||||
: add-todo ( links level spider -- )
|
||||
todo>> push-links ;
|
||||
|
@ -38,64 +67,76 @@ links processing-time timestamp ;
|
|||
: add-nonmatching ( links level spider -- )
|
||||
nonmatching>> push-links ;
|
||||
|
||||
: filter-base ( spider spider-result -- base-links nonmatching-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 ;
|
||||
: url-absolute? ( url -- ? )
|
||||
present "http://" head? ;
|
||||
|
||||
: normalize-hrefs ( links spider -- links' )
|
||||
currently-spidering>> present swap
|
||||
[ dup url-absolute? [ derive-url ] [ url-append-path >url ] if ] 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-all-links 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 < ]
|
||||
[ [ count>> ] [ max-count>> ] bi < ]
|
||||
} 1&& ;
|
||||
|
||||
: setup-next-url ( spider -- spider url depth )
|
||||
dup todo>> peek-url url>> present >>currently-spidering
|
||||
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 ] [ spider-sleep ] [ run-spider-loop ] tri
|
||||
] [
|
||||
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 ;
|
||||
|
|
13
vm/alien.c
13
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)
|
||||
{
|
||||
|
|
|
@ -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)
|
||||
|
||||
|
|
|
@ -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
|
||||
{
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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,
|
||||
|
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue