Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
81ec716782
basis
bootstrap/ui
cocoa/application
compiler
codegen
tree/propagation/known-words
core-foundation/strings
cpu/ppc
documents/elements
hints
io/encodings
ascii
iana
models
quoting
regexp/compiler
sorting/human
tools/deploy/shaker
ui
gadgets/worlds
text
tools
browser
listener
unicode/breaks
core
effects/parser
hashtables
namespaces
slots
syntax
words/alias
extra
bank
html/parser
irc/client
smalltalk
classes
library
listener
selectors
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 [
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -2,7 +2,7 @@ USING: help.markup help.syntax ui.commands ;
|
|||
IN: ui.tools.browser
|
||||
|
||||
ARTICLE: "ui-browser" "UI browser"
|
||||
"The browser is used to display Factor code, documentation, and vocabularies. The browser is opened when a word or articlelink presentation is clicked. It can also be opened using words:"
|
||||
"The browser is used to display Factor code, documentation, and vocabularies. The browser is opened when a word or article link presentation is clicked. It can also be opened using words:"
|
||||
{ $subsection com-browse }
|
||||
{ $subsection browser-window }
|
||||
{ $command-map browser-gadget "toolbar" }
|
||||
|
|
|
|||
|
|
@ -263,8 +263,9 @@ M: listener-operation invoke-command ( target command -- )
|
|||
|
||||
: listener-run-files ( seq -- )
|
||||
[
|
||||
[ \ listener-run-files ] dip
|
||||
'[ _ [ run-file ] each ] call-listener
|
||||
'[ _ [ run-file ] each ]
|
||||
\ listener-run-files
|
||||
call-listener
|
||||
] unless-empty ;
|
||||
|
||||
: com-end ( listener -- )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ] [
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
":" [
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -1,10 +1,12 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays html.parser.utils hashtables io kernel
|
||||
namespaces make prettyprint quotations sequences splitting
|
||||
html.parser.state strings unicode.categories unicode.case ;
|
||||
USING: accessors arrays hashtables html.parser.state
|
||||
html.parser.utils kernel make namespaces sequences
|
||||
unicode.case unicode.categories combinators.short-circuit
|
||||
quoting ;
|
||||
IN: html.parser
|
||||
|
||||
|
||||
TUPLE: tag name attributes text closing? ;
|
||||
|
||||
SINGLETON: text
|
||||
|
|
@ -28,116 +30,103 @@ SYMBOL: tagstack
|
|||
: make-tag ( string attribs -- tag )
|
||||
[ [ closing-tag? ] keep "/" trim1 ] dip rot <tag> ;
|
||||
|
||||
: make-text-tag ( string -- tag )
|
||||
: new-tag ( string type -- tag )
|
||||
tag new
|
||||
text >>name
|
||||
swap >>text ;
|
||||
swap >>name
|
||||
swap >>text ; inline
|
||||
|
||||
: make-comment-tag ( string -- tag )
|
||||
tag new
|
||||
comment >>name
|
||||
swap >>text ;
|
||||
: make-text-tag ( string -- tag ) text new-tag ; inline
|
||||
|
||||
: make-dtd-tag ( string -- tag )
|
||||
tag new
|
||||
dtd >>name
|
||||
swap >>text ;
|
||||
: make-comment-tag ( string -- tag ) comment new-tag ; inline
|
||||
|
||||
: read-whitespace ( -- string )
|
||||
[ get-char blank? not ] take-until ;
|
||||
: make-dtd-tag ( string -- tag ) dtd new-tag ; inline
|
||||
|
||||
: read-whitespace* ( -- ) read-whitespace drop ;
|
||||
: read-single-quote ( state-parser -- string )
|
||||
[ [ CHAR: ' = ] take-until ] [ next drop ] bi ;
|
||||
|
||||
: read-token ( -- string )
|
||||
read-whitespace*
|
||||
[ get-char blank? ] take-until ;
|
||||
: read-double-quote ( state-parser -- string )
|
||||
[ [ CHAR: " = ] take-until ] [ next drop ] bi ;
|
||||
|
||||
: read-single-quote ( -- string )
|
||||
[ get-char CHAR: ' = ] take-until ;
|
||||
: read-quote ( state-parser -- string )
|
||||
dup get+increment CHAR: ' =
|
||||
[ read-single-quote ] [ read-double-quote ] if ;
|
||||
|
||||
: read-double-quote ( -- string )
|
||||
[ get-char CHAR: " = ] take-until ;
|
||||
: read-key ( state-parser -- string )
|
||||
skip-whitespace
|
||||
[ { [ CHAR: = = ] [ blank? ] } 1|| ] take-until ;
|
||||
|
||||
: read-quote ( -- string )
|
||||
get-char next CHAR: ' =
|
||||
[ read-single-quote ] [ read-double-quote ] if next ;
|
||||
: read-= ( state-parser -- )
|
||||
skip-whitespace
|
||||
[ [ CHAR: = = ] take-until drop ] [ next drop ] bi ;
|
||||
|
||||
: read-key ( -- string )
|
||||
read-whitespace*
|
||||
[ get-char [ CHAR: = = ] [ blank? ] bi or ] take-until ;
|
||||
: read-token ( state-parser -- string )
|
||||
[ blank? ] take-until ;
|
||||
|
||||
: read-= ( -- )
|
||||
read-whitespace*
|
||||
[ get-char CHAR: = = ] take-until drop next ;
|
||||
|
||||
: read-value ( -- string )
|
||||
read-whitespace*
|
||||
get-char quote? [ read-quote ] [ read-token ] if
|
||||
: read-value ( state-parser -- string )
|
||||
skip-whitespace
|
||||
dup get-char quote? [ read-quote ] [ read-token ] if
|
||||
[ blank? ] trim ;
|
||||
|
||||
: read-comment ( -- )
|
||||
"-->" take-string make-comment-tag push-tag ;
|
||||
: read-comment ( state-parser -- )
|
||||
"-->" take-until-sequence make-comment-tag push-tag ;
|
||||
|
||||
: read-dtd ( -- )
|
||||
">" take-string make-dtd-tag push-tag ;
|
||||
: read-dtd ( state-parser -- )
|
||||
">" take-until-sequence make-dtd-tag push-tag ;
|
||||
|
||||
: read-bang ( -- )
|
||||
next get-char CHAR: - = get-next CHAR: - = and [
|
||||
: read-bang ( state-parser -- )
|
||||
next dup { [ get-char CHAR: - = ] [ get-next CHAR: - = ] } 1&& [
|
||||
next next
|
||||
read-comment
|
||||
] [
|
||||
read-dtd
|
||||
] if ;
|
||||
|
||||
: read-tag ( -- string )
|
||||
[ get-char CHAR: > = get-char CHAR: < = or ] take-until
|
||||
get-char CHAR: < = [ next ] unless ;
|
||||
: read-tag ( state-parser -- string )
|
||||
[ [ "><" member? ] take-until ]
|
||||
[ dup get-char CHAR: < = [ next ] unless drop ] bi ;
|
||||
|
||||
: read-< ( -- string )
|
||||
next get-char CHAR: ! = [
|
||||
read-bang f
|
||||
: read-until-< ( state-parser -- string )
|
||||
[ CHAR: < = ] take-until ;
|
||||
|
||||
: parse-text ( state-parser -- )
|
||||
read-until-< [ make-text-tag push-tag ] unless-empty ;
|
||||
|
||||
: (parse-attributes) ( state-parser -- )
|
||||
skip-whitespace
|
||||
dup state-parse-end? [
|
||||
drop
|
||||
] [
|
||||
read-tag
|
||||
[
|
||||
[ read-key >lower ] [ read-= ] [ read-value ] tri
|
||||
2array ,
|
||||
] keep (parse-attributes)
|
||||
] if ;
|
||||
|
||||
: read-until-< ( -- string )
|
||||
[ get-char CHAR: < = ] take-until ;
|
||||
|
||||
: parse-text ( -- )
|
||||
read-until-< [
|
||||
make-text-tag push-tag
|
||||
] unless-empty ;
|
||||
|
||||
: (parse-attributes) ( -- )
|
||||
read-whitespace*
|
||||
string-parse-end? [
|
||||
read-key >lower read-= read-value
|
||||
2array , (parse-attributes)
|
||||
] unless ;
|
||||
|
||||
: parse-attributes ( -- hashtable )
|
||||
: parse-attributes ( state-parser -- hashtable )
|
||||
[ (parse-attributes) ] { } make >hashtable ;
|
||||
|
||||
: (parse-tag) ( string -- string' hashtable )
|
||||
[
|
||||
read-token >lower
|
||||
parse-attributes
|
||||
] 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 )
|
||||
next dup get-char [
|
||||
CHAR: ! = [ read-bang f ] [ read-tag ] if
|
||||
] [
|
||||
drop f
|
||||
] if* ;
|
||||
|
||||
: (parse-html) ( -- )
|
||||
get-next [
|
||||
parse-text
|
||||
parse-tag
|
||||
(parse-html)
|
||||
] when ;
|
||||
: parse-tag ( state-parser -- )
|
||||
read-< [ (parse-tag) make-tag push-tag ] unless-empty ;
|
||||
|
||||
: (parse-html) ( state-parser -- )
|
||||
dup get-next [
|
||||
[ parse-text ] [ parse-tag ] [ (parse-html) ] tri
|
||||
] [ drop ] if ;
|
||||
|
||||
: tag-parse ( quot -- vector )
|
||||
V{ } clone tagstack [ string-parse ] with-variable ; inline
|
||||
V{ } clone tagstack [ state-parse ] with-variable ; inline
|
||||
|
||||
: parse-html ( string -- vector )
|
||||
[ (parse-html) tagstack get ] tag-parse ;
|
||||
|
|
|
|||
|
|
@ -1,14 +1,36 @@
|
|||
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?"
|
||||
[ [ [ 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> [ 3 = ] take-until ] unit-test
|
||||
|
||||
[ { 1 2 } ]
|
||||
[ { 1 2 3 4 } <state-parser> { 3 4 } take-until-sequence ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,41 +1,67 @@
|
|||
! Copyright (C) 2005, 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces math kernel sequences accessors fry circular ;
|
||||
USING: namespaces math kernel sequences accessors fry circular
|
||||
unicode.case unicode.categories locals ;
|
||||
|
||||
IN: html.parser.state
|
||||
|
||||
TUPLE: state string i ;
|
||||
TUPLE: state-parser 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
|
||||
: (get-char) ( n state -- char/f )
|
||||
sequence>> ?nth ; inline
|
||||
|
||||
: get-next ( -- char )
|
||||
state get [ i>> 1+ ] [ string>> ] bi ?nth ; inline
|
||||
: get-char ( state -- char/f )
|
||||
[ n>> ] keep (get-char) ; inline
|
||||
|
||||
: next ( -- )
|
||||
state get [ 1+ ] change-i drop ; inline
|
||||
: get-next ( state -- char/f )
|
||||
[ n>> 1 + ] keep (get-char) ; inline
|
||||
|
||||
: string-parse ( string quot -- )
|
||||
[ 0 state boa state ] dip with-variable ; inline
|
||||
: next ( state -- state )
|
||||
[ 1 + ] change-n ; inline
|
||||
|
||||
: short* ( n seq -- n' seq )
|
||||
over [ nip dup length swap ] unless ; inline
|
||||
: get+increment ( state -- char/f )
|
||||
[ get-char ] [ next drop ] bi ; inline
|
||||
|
||||
: skip-until ( quot: ( -- ? ) -- )
|
||||
get-char [
|
||||
[ call ] keep swap
|
||||
[ drop ] [ next skip-until ] if
|
||||
] [ drop ] if ; inline recursive
|
||||
: state-parse ( sequence quot -- )
|
||||
[ <state-parser> ] dip call ; inline
|
||||
|
||||
: take-until ( quot: ( -- ? ) -- )
|
||||
get-i [ skip-until ] dip get-i
|
||||
state get string>> subseq ; inline
|
||||
:: skip-until ( state quot: ( obj -- ? ) -- )
|
||||
state get-char [
|
||||
quot call [ state next quot skip-until ] unless
|
||||
] when* ; inline recursive
|
||||
|
||||
: string-matches? ( string circular -- ? )
|
||||
get-char over push-growing-circular sequence= ; inline
|
||||
: state-parse-end? ( state -- ? ) get-next not ;
|
||||
|
||||
: take-string ( match -- string )
|
||||
dup length <growing-circular>
|
||||
[ 2dup string-matches? ] take-until nip
|
||||
dup length rot length 1- - head next ; inline
|
||||
: take-until ( state quot: ( obj -- ? ) -- sequence/f )
|
||||
over state-parse-end? [
|
||||
2drop f
|
||||
] [
|
||||
[ drop n>> ]
|
||||
[ skip-until ]
|
||||
[ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq
|
||||
] if ; inline
|
||||
|
||||
:: take-until-sequence ( state-parser sequence -- sequence' )
|
||||
sequence length <growing-circular> :> growing
|
||||
state-parser
|
||||
[
|
||||
growing push-growing-circular
|
||||
sequence growing sequence=
|
||||
] take-until :> found
|
||||
found dup length
|
||||
growing length 1- - head
|
||||
state-parser next drop ;
|
||||
|
||||
: skip-whitespace ( state -- state )
|
||||
[ [ blank? not ] take-until drop ] keep ;
|
||||
|
||||
: take-rest ( state -- sequence )
|
||||
[ drop f ] take-until ; inline
|
||||
|
||||
: take-until-object ( state obj -- sequence )
|
||||
'[ _ = ] take-until ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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,8 +3,8 @@
|
|||
USING: accessors fry html.parser html.parser.analyzer
|
||||
http.client kernel tools.time sets assocs sequences
|
||||
concurrency.combinators io threads namespaces math multiline
|
||||
heaps math.parser inspector urls assoc-heaps logging
|
||||
combinators.short-circuit continuations calendar prettyprint ;
|
||||
math.parser inspector urls logging combinators.short-circuit
|
||||
continuations calendar prettyprint dlists deques locals ;
|
||||
IN: spider
|
||||
|
||||
TUPLE: spider base count max-count sleep max-depth initial-links
|
||||
|
|
@ -13,12 +13,33 @@ filters spidered todo nonmatching quiet ;
|
|||
TUPLE: spider-result url depth headers fetch-time parsed-html
|
||||
links processing-time timestamp ;
|
||||
|
||||
TUPLE: todo-url url depth ;
|
||||
|
||||
: <todo-url> ( url depth -- todo-url )
|
||||
todo-url new
|
||||
swap >>depth
|
||||
swap >>url ;
|
||||
|
||||
TUPLE: unique-deque assoc deque ;
|
||||
|
||||
: <unique-deque> ( -- unique-deque )
|
||||
H{ } clone <dlist> unique-deque boa ;
|
||||
|
||||
: push-url ( url depth unique-deque -- )
|
||||
[ <todo-url> ] dip
|
||||
[ [ [ t ] dip url>> ] [ assoc>> ] bi* set-at ]
|
||||
[ deque>> push-back ] 2bi ;
|
||||
|
||||
: pop-url ( unique-deque -- todo-url ) deque>> pop-front ;
|
||||
|
||||
: peek-url ( unique-deque -- todo-url ) deque>> peek-front ;
|
||||
|
||||
: <spider> ( base -- spider )
|
||||
>url
|
||||
spider new
|
||||
over >>base
|
||||
swap 0 <unique-min-heap> [ heap-push ] keep >>todo
|
||||
<unique-min-heap> >>nonmatching
|
||||
swap 0 <unique-deque> [ push-url ] keep >>todo
|
||||
<unique-deque> >>nonmatching
|
||||
0 >>max-depth
|
||||
0 >>count
|
||||
1/0. >>max-count
|
||||
|
|
@ -27,10 +48,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 +59,72 @@ 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 ;
|
||||
: normalize-hrefs ( links spider -- links' )
|
||||
[ [ >url ] map ] dip
|
||||
base>> swap [ derive-url ] with map ;
|
||||
|
||||
: print-spidering ( url depth -- )
|
||||
"depth: " write number>string write
|
||||
", spidering: " write . yield ;
|
||||
|
||||
: (spider-page) ( url depth -- spider-result )
|
||||
f pick spider get spidered>> set-at
|
||||
over '[ _ http-get ] benchmark swap
|
||||
[ parse-html dup find-hrefs normalize-hrefs ] benchmark
|
||||
:: new-spidered-result ( spider url depth -- spider-result )
|
||||
f url spider spidered>> set-at
|
||||
[ url http-get ] benchmark :> fetch-time :> html :> headers
|
||||
[
|
||||
html parse-html [ ] [ find-hrefs spider normalize-hrefs ] bi
|
||||
] benchmark :> processing-time :> links :> parsed-html
|
||||
url depth headers fetch-time parsed-html links processing-time
|
||||
now spider-result boa ;
|
||||
|
||||
: spider-page ( url depth -- )
|
||||
spider get quiet>> [ 2dup print-spidering ] unless
|
||||
(spider-page)
|
||||
spider get [ quiet>> [ dup describe ] unless ]
|
||||
[ swap add-spidered ] bi ;
|
||||
:: spider-page ( spider url depth -- )
|
||||
spider quiet>> [ url depth print-spidering ] unless
|
||||
spider url depth new-spidered-result :> spidered-result
|
||||
spider quiet>> [ spidered-result describe ] unless
|
||||
spider spidered-result add-spidered ;
|
||||
|
||||
\ spider-page ERROR add-error-logging
|
||||
|
||||
: spider-sleep ( -- )
|
||||
spider get sleep>> [ sleep ] when* ;
|
||||
: spider-sleep ( spider -- )
|
||||
sleep>> [ sleep ] when* ;
|
||||
|
||||
: queue-initial-links ( spider -- spider )
|
||||
[ initial-links>> normalize-hrefs 0 ] keep
|
||||
[ add-todo ] keep ;
|
||||
:: queue-initial-links ( spider -- spider )
|
||||
spider initial-links>> spider normalize-hrefs 0 spider add-todo spider ;
|
||||
|
||||
: slurp-heap-while ( heap quot1 quot2: ( value key -- ) -- )
|
||||
pick heap-empty? [ 3drop ] [
|
||||
[ [ heap-pop dup ] 2dip slip [ t ] compose [ 2drop f ] if ]
|
||||
[ roll [ slurp-heap-while ] [ 3drop ] if ] 3bi
|
||||
] if ; inline recursive
|
||||
: spider-page? ( spider -- ? )
|
||||
{
|
||||
[ todo>> deque>> deque-empty? not ]
|
||||
[ [ todo>> peek-url depth>> ] [ max-depth>> ] bi < ]
|
||||
[ [ count>> ] [ max-count>> ] bi < ]
|
||||
} 1&& ;
|
||||
|
||||
: setup-next-url ( spider -- spider url depth )
|
||||
dup todo>> pop-url [ url>> ] [ depth>> ] bi ;
|
||||
|
||||
: spider-next-page ( spider -- )
|
||||
setup-next-url spider-page ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: run-spider-loop ( spider -- )
|
||||
dup spider-page? [
|
||||
[ spider-next-page ] [ run-spider-loop ] bi
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
|
||||
: run-spider ( spider -- spider )
|
||||
"spider" [
|
||||
dup spider [
|
||||
queue-initial-links
|
||||
[ todo>> ] [ max-depth>> ] bi
|
||||
'[
|
||||
_ <= spider get
|
||||
[ count>> ] [ max-count>> ] bi < and
|
||||
] [ spider-page spider-sleep ] slurp-heap-while
|
||||
spider get
|
||||
] with-variable
|
||||
queue-initial-links [ run-spider-loop ] keep
|
||||
] with-logging ;
|
||||
|
|
|
|||
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));
|
||||
|
|
@ -195,8 +195,6 @@ void mark_code_block(F_CODE_BLOCK *compiled)
|
|||
|
||||
copy_handle(&compiled->literals);
|
||||
copy_handle(&compiled->relocation);
|
||||
|
||||
flush_icache_for(compiled);
|
||||
}
|
||||
|
||||
void mark_stack_frame_step(F_STACK_FRAME *frame)
|
||||
|
|
@ -370,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]);
|
||||
|
|
@ -431,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,
|
||||
|
|
|
|||
11
vm/debug.c
11
vm/debug.c
|
|
@ -311,7 +311,7 @@ void find_data_references(CELL look_for_)
|
|||
/* Dump all code blocks for debugging */
|
||||
void dump_code_heap(void)
|
||||
{
|
||||
CELL size = 0;
|
||||
CELL reloc_size = 0, literal_size = 0;
|
||||
|
||||
F_BLOCK *scan = first_block(&code_heap);
|
||||
|
||||
|
|
@ -324,11 +324,13 @@ void dump_code_heap(void)
|
|||
status = "free";
|
||||
break;
|
||||
case B_ALLOCATED:
|
||||
size += object_size(((F_CODE_BLOCK *)scan)->relocation);
|
||||
reloc_size += object_size(((F_CODE_BLOCK *)scan)->relocation);
|
||||
literal_size += object_size(((F_CODE_BLOCK *)scan)->literals);
|
||||
status = "allocated";
|
||||
break;
|
||||
case B_MARKED:
|
||||
size += object_size(((F_CODE_BLOCK *)scan)->relocation);
|
||||
reloc_size += object_size(((F_CODE_BLOCK *)scan)->relocation);
|
||||
literal_size += object_size(((F_CODE_BLOCK *)scan)->literals);
|
||||
status = "marked";
|
||||
break;
|
||||
default:
|
||||
|
|
@ -343,7 +345,8 @@ void dump_code_heap(void)
|
|||
scan = next_block(&code_heap,scan);
|
||||
}
|
||||
|
||||
print_cell(size); print_string(" bytes of relocation data\n");
|
||||
print_cell(reloc_size); print_string(" bytes of relocation data\n");
|
||||
print_cell(literal_size); print_string(" bytes of literal data\n");
|
||||
}
|
||||
|
||||
void factorbug(void)
|
||||
|
|
|
|||
|
|
@ -180,7 +180,8 @@ void jit_compile(CELL quot, bool relocate)
|
|||
GROWABLE_ARRAY(literals);
|
||||
REGISTER_ROOT(literals);
|
||||
|
||||
GROWABLE_ARRAY_ADD(literals,stack_traces_p() ? quot : F);
|
||||
if(stack_traces_p())
|
||||
GROWABLE_ARRAY_ADD(literals,quot);
|
||||
|
||||
bool stack_frame = jit_stack_frame_p(untag_object(array));
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue