Merge branch 'master' of git://factorcode.org/git/factor

db4
U-SLAVA-DFB8FF805\Slava 2009-04-02 13:11:38 -05:00
commit 6b8f4ecabc
140 changed files with 2556 additions and 519 deletions

View File

@ -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." ;

View File

@ -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

View File

@ -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

View File

@ -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 )
[

View File

@ -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

View File

@ -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 )

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -182,7 +182,7 @@ link-no-follow? off
[ "<table><tr><td>foo|bar</td></tr></table>" ] [ "|foo\\|bar|" convert-farkup ] unit-test
[ "<p></p>" ] [ "\\" convert-farkup ] unit-test
! [ "<p>[abc]</p>" ] [ "[abc]" convert-farkup ] unit-test
[ "<p>[abc]</p>" ] [ "[abc]" convert-farkup ] unit-test
: random-markup ( -- string )
10 [

View File

@ -121,7 +121,7 @@ DEFER: (parse-paragraph)
] if
] if ;
: take-until ( state delimiter -- string/f state' )
: take-until ( state delimiter -- string state'/f )
V{ } clone (take-until) ;
: count= ( string -- n )
@ -186,11 +186,12 @@ DEFER: (parse-paragraph)
: parse-code ( state -- state' item )
dup 1 look CHAR: [ =
[ unclip-slice make-paragraph ] [
"{" take-until
[ rest ] dip
"}]" take-until
[ code boa ] dip swap
[ take-line make-paragraph ] [
dup "{" take-until [
[ nip rest ] dip
"}]" take-until
[ code boa ] dip swap
] [ drop take-line make-paragraph ] if*
] if ;
: parse-item ( state -- state' item )

View File

@ -20,6 +20,8 @@ TIP: "Power tools: " { $links see edit help about apropos time infer. } ;
TIP: "Tips of the day implement the " { $link "definition-protocol" } " and new tips of the day can be defined using the " { $link POSTPONE: TIP: } " parsing word." ;
TIP: "Try some simple demo applications, then look at the source code in " { $snippet "extra/" } ": " { $code "\"demos\" run" } ;
HELP: TIP:
{ $syntax "TIP: content ;" }
{ $values { "content" "a markup element" } }

View File

@ -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

View File

@ -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< ;

View File

@ -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

View File

@ -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"

View File

@ -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

View File

@ -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

View File

@ -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:"

View File

@ -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>

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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

View File

@ -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 )

View File

@ -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 ;

View File

@ -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 }

View File

@ -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

View File

@ -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

View File

@ -157,6 +157,7 @@ IN: tools.deploy.shaker
"specializer"
"step-into"
"step-into?"
"superclass"
"transform-n"
"transform-quot"
"tuple-dispatch-generic"

View File

@ -11,6 +11,7 @@ CONSTANT: horizontal { 1 0 }
CONSTANT: vertical { 0 1 }
TUPLE: gadget < rect
id
pref-dim
parent
children
@ -28,7 +29,7 @@ model ;
M: gadget equal? 2drop f ;
M: gadget hashcode* drop gadget hashcode* ;
M: gadget hashcode* nip [ [ \ gadget counter ] unless* ] change-id id>> ;
M: gadget model-changed 2drop ;

View File

@ -49,13 +49,13 @@ M: pane-stream stream-element-type drop +character+ ;
: pane-caret&mark ( pane -- caret mark )
[ caret>> ] [ mark>> ] bi ; inline
: selected-children ( pane -- seq )
: selected-subtree ( pane -- seq )
[ pane-caret&mark sort-pair ] keep gadget-subtree ;
M: pane gadget-selection? pane-caret&mark and ;
M: pane gadget-selection ( pane -- string/f )
selected-children gadget-text ;
selected-subtree gadget-text ;
: init-prototype ( pane -- pane )
<shelf> +baseline+ >>align >>prototype ; inline
@ -72,31 +72,12 @@ M: pane gadget-selection ( pane -- string/f )
[ >>last-line ] [ 1 track-add ] bi
dup prepare-last-line ; inline
GENERIC: draw-selection ( loc obj -- )
: if-fits ( rect quot -- )
[ clip get over contains-rect? ] dip [ drop ] if ; inline
M: gadget draw-selection ( loc gadget -- )
swap offset-rect [
rect-bounds gl-fill-rect
] if-fits ;
M: node draw-selection ( loc node -- )
2dup value>> swap offset-rect [
drop 2dup
[ value>> loc>> v+ ] keep
children>> [ draw-selection ] with each
] if-fits 2drop ;
M: pane draw-gadget*
M: pane selected-children
dup gadget-selection? [
[ selection-color>> gl-color ]
[
[ loc>> vneg ] keep selected-children
[ draw-selection ] with each
] bi
] [ drop ] if ;
[ selected-subtree leaves ]
[ selection-color>> ]
bi
] [ drop f f ] if ;
: scroll-pane ( pane -- )
dup scrolls?>> [ scroll>bottom ] [ drop ] if ;

View File

@ -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.

View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math.rectangles math.vectors namespaces kernel accessors
combinators sequences opengl opengl.gl opengl.glu colors
assocs combinators sequences opengl opengl.gl opengl.glu colors
colors.constants ui.gadgets ui.pens ;
IN: ui.render
@ -55,21 +55,57 @@ SYMBOL: origin
GENERIC: draw-children ( gadget -- )
! For gadget selection
SYMBOL: selected-gadgets
SYMBOL: selection-background
GENERIC: selected-children ( gadget -- assoc/f selection-background )
M: gadget selected-children drop f f ;
! For text rendering
SYMBOL: background
SYMBOL: foreground
GENERIC: gadget-background ( gadget -- color )
M: gadget gadget-background dup interior>> pen-background ;
GENERIC: gadget-foreground ( gadget -- color )
M: gadget gadget-foreground dup interior>> pen-foreground ;
<PRIVATE
: draw-selection-background ( gadget -- )
selection-background get background set
selection-background get gl-color
[ { 0 0 } ] dip dim>> gl-fill-rect ;
: draw-standard-background ( object -- )
dup interior>> dup [ draw-interior ] [ 2drop ] if ;
: draw-background ( gadget -- )
origin get [
[
dup selected-gadgets get key?
[ draw-selection-background ]
[ draw-standard-background ] if
] [ draw-gadget* ] bi
] with-translation ;
: draw-border ( object -- )
dup boundary>> dup [
origin get [ draw-boundary ] with-translation
] [ 2drop ] if ;
PRIVATE>
: (draw-gadget) ( gadget -- )
dup loc>> origin get v+ origin [
[
origin get [
[ dup interior>> dup [ draw-interior ] [ 2drop ] if ]
[ draw-gadget* ]
bi
] with-translation
]
[ draw-children ]
[
dup boundary>> dup [
origin get [ draw-boundary ] with-translation
] [ 2drop ] if
] tri
[ draw-background ] [ draw-children ] [ draw-border ] tri
] with-variable ;
: >absolute ( rect -- rect )
@ -88,27 +124,24 @@ GENERIC: draw-children ( gadget -- )
[ [ (draw-gadget) ] with-clipping ]
} cond ;
! For text rendering
SYMBOL: background
SYMBOL: foreground
GENERIC: gadget-background ( gadget -- color )
M: gadget gadget-background dup interior>> pen-background ;
GENERIC: gadget-foreground ( gadget -- color )
M: gadget gadget-foreground dup interior>> pen-foreground ;
M: gadget draw-children
[ visible-children ]
[ gadget-background ]
[ gadget-foreground ] tri [
[ foreground set ] when*
[ background set ] when*
[ draw-gadget ] each
] with-scope ;
dup children>> [
{
[ visible-children ]
[ selected-children ]
[ gadget-background ]
[ gadget-foreground ]
} cleave [
{
[ [ selected-gadgets set ] when* ]
[ [ selection-background set ] when* ]
[ [ background set ] when* ]
[ [ foreground set ] when* ]
} spread
[ draw-gadget ] each
] with-scope
] [ drop ] if ;
CONSTANT: selection-color T{ rgba f 0.8 0.8 1.0 1.0 }

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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

View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors namespaces make sequences kernel math arrays io
ui.gadgets generic combinators ;
ui.gadgets generic combinators fry sets ;
IN: ui.traverse
TUPLE: node value children ;
@ -85,3 +85,13 @@ M: node gadget-text*
: gadget-at-path ( parent path -- gadget )
[ swap nth-gadget ] each ;
GENERIC# leaves* 1 ( tree assoc -- )
M: node leaves* [ children>> ] dip leaves* ;
M: array leaves* '[ _ leaves* ] each ;
M: gadget leaves* conjoin ;
: leaves ( tree -- assoc ) H{ } clone [ leaves* ] keep ;

View File

@ -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 ;

View File

@ -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" ;

View File

@ -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

View File

@ -12,3 +12,8 @@ IN: unicode.categories.tests
[ "Lo" ] [ HEX: 3450 category ] unit-test
[ "Lo" ] [ HEX: 4DB5 category ] unit-test
[ "Cs" ] [ HEX: DD00 category ] unit-test
[ t ] [ CHAR: \t blank? ] unit-test
[ t ] [ CHAR: \s blank? ] unit-test
[ t ] [ CHAR: \r blank? ] unit-test
[ t ] [ CHAR: \n blank? ] unit-test
[ f ] [ CHAR: a blank? ] unit-test

View File

@ -3,7 +3,7 @@
USING: unicode.categories.syntax sequences unicode.data ;
IN: unicode.categories
CATEGORY: blank Zs Zl Zp | "\r\n" member? ;
CATEGORY: blank Zs Zl Zp | "\r\n\t" member? ;
CATEGORY: letter Ll | "Other_Lowercase" property? ;
CATEGORY: LETTER Lu | "Other_Uppercase" property? ;
CATEGORY: Letter Lu Ll Lt Lm Lo Nl ;

View File

@ -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 ;"

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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

View File

@ -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 ] [

View File

@ -138,7 +138,7 @@ IN: bootstrap.syntax
] define-core-syntax
"CONSTANT:" [
CREATE scan-object define-constant
CREATE-WORD scan-object define-constant
] define-core-syntax
":" [

View File

@ -0,0 +1,6 @@
USING: math eval tools.test effects ;
IN: words.alias.tests
ALIAS: foo +
[ ] [ "IN: words.alias.tests CONSTANT: foo 5" eval ] unit-test
[ (( -- value )) ] [ \ foo stack-effect ] unit-test

View File

@ -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 ;

View File

@ -0,0 +1 @@
Doug Coleman

View File

@ -0,0 +1,26 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test c.preprocessor kernel accessors multiline ;
IN: c.preprocessor.tests
[ "vocab:c/tests/test1/test1.c" start-preprocess-file ]
[ include-nested-too-deeply? ] must-fail-with
[ "yo\n\n\n\nyo4\n" ]
[ "vocab:c/tests/test2/test2.c" start-preprocess-file nip ] unit-test
/*
[ "vocab:c/tests/test3/test3.c" start-preprocess-file ]
[ "\"BOO\"" = ] must-fail-with
*/
[ V{ "\"omg\"" "\"lol\"" } ]
[ "vocab:c/tests/test4/test4.c" start-preprocess-file drop warnings>> ] unit-test
/*
f(2 * (y+1)) + f(2 * (f(2 * (z[0])))) % f(2 * (0)) + t(1);
f(2 * (2+(3,4)-0,1)) | f(2 * (~ 5)) & f(2 * (0,1))^m(0,1);
int i[] = { 1, 23, 4, 5, };
char c[2][6] = { "hello", "" };
*/

View File

@ -0,0 +1,193 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: html.parser.state io io.encodings.utf8 io.files
io.streams.string kernel combinators accessors io.pathnames
fry sequences arrays locals namespaces io.directories
assocs math splitting make unicode.categories
combinators.short-circuit ;
IN: c.preprocessor
: initial-library-paths ( -- seq )
V{ "/usr/include" } clone ;
: initial-symbol-table ( -- hashtable )
H{
{ "__APPLE__" "" }
{ "__amd64__" "" }
{ "__x86_64__" "" }
} clone ;
TUPLE: preprocessor-state library-paths symbol-table
include-nesting include-nesting-max processing-disabled?
ifdef-nesting warnings errors
pragmas
include-nexts
ifs elifs elses ;
: <preprocessor-state> ( -- preprocessor-state )
preprocessor-state new
initial-library-paths >>library-paths
initial-symbol-table >>symbol-table
0 >>include-nesting
200 >>include-nesting-max
0 >>ifdef-nesting
V{ } clone >>warnings
V{ } clone >>errors
V{ } clone >>pragmas
V{ } clone >>include-nexts
V{ } clone >>ifs
V{ } clone >>elifs
V{ } clone >>elses ;
DEFER: preprocess-file
ERROR: unknown-c-preprocessor state-parser name ;
ERROR: bad-include-line line ;
ERROR: header-file-missing path ;
:: read-standard-include ( preprocessor-state path -- )
preprocessor-state dup library-paths>>
[ path append-path exists? ] find nip
[
dup [
path append-path
preprocess-file
] with-directory
] [
! path header-file-missing
drop
] if* ;
:: read-local-include ( preprocessor-state path -- )
current-directory get path append-path dup :> full-path
dup exists? [
[ preprocessor-state ] dip preprocess-file
] [
! full-path header-file-missing
drop
] if ;
: handle-include ( preprocessor-state state-parser -- )
skip-whitespace advance dup previous {
{ CHAR: < [ CHAR: > take-until-object read-standard-include ] }
{ CHAR: " [ CHAR: " take-until-object read-local-include ] }
[ bad-include-line ]
} case ;
: (readlns) ( -- )
readln "\\" ?tail [ , ] dip [ (readlns) ] when ;
: readlns ( -- string ) [ (readlns) ] { } make concat ;
: take-define-identifier ( state-parser -- string )
skip-whitespace
[ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ;
: handle-define ( preprocessor-state state-parser -- )
[ take-define-identifier ]
[ skip-whitespace take-rest ] bi
"\\" ?tail [ readlns append ] when
spin symbol-table>> set-at ;
: handle-undef ( preprocessor-state state-parser -- )
take-token swap symbol-table>> delete-at ;
: handle-ifdef ( preprocessor-state state-parser -- )
[ [ 1 + ] change-ifdef-nesting ] dip
take-token over symbol-table>> key?
[ drop ] [ t >>processing-disabled? drop ] if ;
: handle-ifndef ( preprocessor-state state-parser -- )
[ [ 1 + ] change-ifdef-nesting ] dip
take-token over symbol-table>> key?
[ t >>processing-disabled? drop ]
[ drop ] if ;
: handle-endif ( preprocessor-state state-parser -- )
drop [ 1 - ] change-ifdef-nesting drop ;
: handle-if ( preprocessor-state state-parser -- )
[ [ 1 + ] change-ifdef-nesting ] dip
skip-whitespace take-rest swap ifs>> push ;
: handle-elif ( preprocessor-state state-parser -- )
skip-whitespace take-rest swap elifs>> push ;
: handle-else ( preprocessor-state state-parser -- )
skip-whitespace take-rest swap elses>> push ;
: handle-pragma ( preprocessor-state state-parser -- )
skip-whitespace take-rest swap pragmas>> push ;
: handle-include-next ( preprocessor-state state-parser -- )
skip-whitespace take-rest swap include-nexts>> push ;
: handle-error ( preprocessor-state state-parser -- )
skip-whitespace take-rest swap errors>> push ;
! nip take-rest throw ;
: handle-warning ( preprocessor-state state-parser -- )
skip-whitespace
take-rest swap warnings>> push ;
: parse-directive ( preprocessor-state state-parser string -- )
{
{ "warning" [ handle-warning ] }
{ "error" [ handle-error ] }
{ "include" [ handle-include ] }
{ "define" [ handle-define ] }
{ "undef" [ handle-undef ] }
{ "ifdef" [ handle-ifdef ] }
{ "ifndef" [ handle-ifndef ] }
{ "endif" [ handle-endif ] }
{ "if" [ handle-if ] }
{ "elif" [ handle-elif ] }
{ "else" [ handle-else ] }
{ "pragma" [ handle-pragma ] }
{ "include_next" [ handle-include-next ] }
[ unknown-c-preprocessor ]
} case ;
: parse-directive-line ( preprocessor-state state-parser -- )
advance dup take-token
pick processing-disabled?>> [
"endif" = [
drop f >>processing-disabled?
[ 1 - ] change-ifdef-nesting
drop
] [ 2drop ] if
] [
parse-directive
] if ;
: preprocess-line ( preprocessor-state state-parser -- )
skip-whitespace dup current CHAR: # =
[ parse-directive-line ]
[ swap processing-disabled?>> [ drop ] [ write-full nl ] if ] if ;
: preprocess-lines ( preprocessor-state -- )
readln
[ <state-parser> [ preprocess-line ] [ drop preprocess-lines ] 2bi ]
[ drop ] if* ;
ERROR: include-nested-too-deeply ;
: check-nesting ( preprocessor-state -- preprocessor-state )
[ 1 + ] change-include-nesting
dup [ include-nesting>> ] [ include-nesting-max>> ] bi > [
include-nested-too-deeply
] when ;
: preprocess-file ( preprocessor-state path -- )
[ check-nesting ] dip
[ utf8 [ preprocess-lines ] with-file-reader ]
[ drop [ 1 - ] change-include-nesting drop ] 2bi ;
: start-preprocess-file ( path -- preprocessor-state string )
dup parent-directory [
[
[ <preprocessor-state> dup ] dip preprocess-file
] with-string-writer
] with-directory ;

View File

@ -0,0 +1 @@
Tests if the preprocessor bails on an infinite loop caused by mutually recursive #include lines.

1
extra/c/tests/test1/hi.h Normal file
View File

@ -0,0 +1 @@
#include "lo.h"

1
extra/c/tests/test1/lo.h Normal file
View File

@ -0,0 +1 @@
#include "hi.h"

View File

@ -0,0 +1 @@
#include "hi.h"

View File

@ -0,0 +1,3 @@
/*
# lol
*/

View File

@ -0,0 +1 @@
foo.h ftw

View File

@ -0,0 +1,2 @@
#define FOO_H "foo.h"
#include FOO_H

View File

@ -0,0 +1,3 @@
#if 4 > (5 - 4++)
#error "Umm"
#endif

View File

@ -0,0 +1,2 @@
#if 10
#error "Umm"

View File

@ -0,0 +1,15 @@
#if 4 > (1 + 2)
good
#endif
#if 4 > 1 + 2
good
#endif
#if (4 > 1) - 1
bad
#endif
#if (4 > 1) - 2
good
#endif

View File

@ -0,0 +1 @@
Tests whether #define and #ifdef/#endif work in the positive case.

View File

@ -0,0 +1,17 @@
#define YO
#ifdef YO
yo
#endif
#define YO2
#ifndef YO2
yo2
#endif
#ifdef YO3
yo3
#endif
#ifndef YO4
yo4
#endif

View File

@ -0,0 +1 @@
Tests whether #define and #ifdef/#endif work in the positive case.

View File

@ -0,0 +1 @@
#error "BOO"

View File

@ -0,0 +1,2 @@
#warning "omg"
#warning "lol"

View File

@ -0,0 +1,3 @@
#define TABSIZE 100
int table[TABSIZE];

View File

@ -0,0 +1 @@
#define max(a, b) ((a) > (b) ? (a) : (b))

View File

@ -0,0 +1,19 @@
#define x 3
#define f(a) f(x * (a))
#undef x
#define x 2
#define g f
#define z z[0]
#define h g(~
#define m(a) a(w)
#define w 0,1
#define t(a) a
#define p() int
#define q(x) x
#define r(x,y) x ## y
#define str(x) # x
f(y+1) + f(f(z)) % t(t(g)(0) + t)(1);
g(x+(3,4)-w) | h 5) & m
(f)^m(m);
p() i[q()] = { q(1), r(2,3), r(4,), r(,5), r(,) };
char c[2][6] = { str(hello), str() };

View File

@ -0,0 +1,15 @@
#define str(s) #s
#define xstr(s) str(s)
#define debug(s, t) printf("x" # s "= %d, x" # t "= %s", \
x ## s, x ## t)
#define INCFILE(n) vers ## n
#define glue(a, b) a## b
#define xglue(a, b) glue(a, b)
#define HIGHLOW "hello"
#define LOW LOW ", world"
debug(1, 2);
fputs(str(strncmp("abc\0d", "abc", '\4') //this goes away
== 0) str(: @\n), s);
#include xstr(INCFILE(2).h)
glue(HIGH, LOW);
xglue(HIGH, LOW)

View File

@ -0,0 +1,4 @@
#define t(x,y,z) x ## y ## z
int j[] = { t(1,2,3), t(,4,5), t(6,,7), t(8,9,),
t(10,,), t(,11,), t(,,12), t(,,) };

View File

@ -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" }
}

1
extra/chicago-talk/summary.txt Executable file
View File

@ -0,0 +1 @@
Slides for a talk at the Pycon VM Summit, Chicago, IL, March 2009

View File

@ -0,0 +1 @@
demos

View File

@ -1,22 +1,16 @@
USING: kernel fry sequences
vocabs.loader help.vocabs
ui ui.gadgets ui.gadgets.buttons ui.gadgets.packs ui.gadgets.scrollers
ui.tools.listener
accessors ;
USING: kernel fry sequences vocabs.loader help.vocabs ui
ui.gadgets ui.gadgets.buttons ui.gadgets.packs ui.gadgets.borders
ui.gadgets.scrollers ui.tools.listener accessors ;
IN: demos
: demo-vocabs ( -- seq ) "demos" tagged [ second ] map concat [ name>> ] map ;
: <run-vocab-button> ( vocab-name -- button )
dup '[ drop [ _ run ] call-listener ] <border-button> ;
dup '[ drop [ _ run ] \ run call-listener ] <border-button> ;
: <demo-runner> ( -- gadget )
<pile> 1 >>fill demo-vocabs [ <run-vocab-button> add-gadget ] each ;
<pile> 1 >>fill { 2 2 } >>gap demo-vocabs [ <run-vocab-button> add-gadget ] each ;
: demos ( -- ) [ <demo-runner> <scroller> "Demos" open-window ] with-ui ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: demos ( -- ) [ <demo-runner> { 2 2 } <border> <scroller> "Demos" open-window ] with-ui ;
MAIN: demos

View File

@ -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

View File

@ -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 }

View File

@ -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 ;

View File

@ -1,14 +1,101 @@
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
[ "" ]
[ "" <state-parser> take-rest ] unit-test
[ "" ]
[ "abc" <state-parser> dup "abc" take-sequence drop take-rest ] unit-test

View File

@ -1,41 +1,120 @@
! 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 io splitting ;
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-slice ( state-parser -- sequence/f )
[ sequence>> ] [ n>> ] bi
2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
: take-rest ( state-parser -- sequence )
[ take-rest-slice ] [ sequence>> like ] bi ;
: 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* ;
: write-full ( state-parser -- ) sequence>> write ;
: write-rest ( state-parser -- ) take-rest write ;

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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" }
}

View File

@ -1 +1 @@
Slides for a talk at Ruby.mn, Minneapolis MN, January 2008
Slides for a talk at Ruby.mn, Minneapolis, MN, January 2008

View File

@ -6,20 +6,20 @@ IN: peg.pl0
#! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0
EBNF: pl0
EBNF: pl0
block = { "CONST" ident "=" number { "," ident "=" number }* ";" }?
{ "VAR" ident { "," ident }* ";" }?
{ "PROCEDURE" ident ";" { block ";" }? }* statement
statement = { ident ":=" expression
| "CALL" ident
| "BEGIN" statement { ";" statement }* "END"
| "IF" condition "THEN" statement
| "WHILE" condition "DO" statement }?
block = { "CONST" ident "=" number { "," ident "=" number }* ";" }?
{ "VAR" ident { "," ident }* ";" }?
{ "PROCEDURE" ident ";" { block ";" }? }* statement
statement = { ident ":=" expression
| "CALL" ident
| "BEGIN" statement { ";" statement }* "END"
| "IF" condition "THEN" statement
| "WHILE" condition "DO" statement }?
condition = { "ODD" expression }
| { expression ("=" | "#" | "<=" | "<" | ">=" | ">") expression }
expression = {"+" | "-"}? term { {"+" | "-"} term }*
term = factor { {"*" | "/"} factor }*
expression = {"+" | "-"}? term { {"+" | "-"} term }*
term = factor { {"*" | "/"} factor }*
factor = ident | number | "(" expression ")"
ident = (([a-zA-Z])+) => [[ >string ]]
digit = ([0-9]) => [[ digit> ]]

View File

@ -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 ;

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -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

Some files were not shown because too many files have changed in this diff Show More