factor.com -i=boot.<cpu>.image
-Before bootstrapping, you will need to download the DLLs for the Pango
-text rendering library. The required DLLs are listed in
-build-support/dlls.txt and are available from the following location:
-
- <http://factorcode.org/dlls>
-
Once bootstrapped, double-clicking factor.exe or factor.com starts
the Factor UI.
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: functors destructors accessors kernel parser words ;
+USING: functors destructors accessors kernel parser words
+effects generalizations sequences ;
IN: alien.destructors
SLOT: alien
<F-destructor> DEFINES <${F}-destructor>
&F DEFINES &${F}
|F DEFINES |${F}
+N [ F stack-effect out>> length ]
WHERE
: <F-destructor> ( alien -- destructor ) f F-destructor boa ; inline
-M: F-destructor dispose* alien>> F ;
+M: F-destructor dispose* alien>> F N ndrop ;
: &F ( alien -- alien ) dup <F-destructor> &dispose drop ; inline
ARTICLE: "alien.fortran-abis" "Fortran ABIs"
"Fortran does not have a standard ABI like C does. Factor supports the following Fortran ABIs:"
{ $list
- { { $subsection gfortran-abi } " is used by gfortran, the Fortran compiler included with GCC 4." }
- { { $subsection f2c-abi } " is used by the F2C Fortran-to-C translator and G77, the Fortran compiler included with GCC 3.x and earlier. It is also used by gfortran when compiling with the -ff2c flag." }
- { { $subsection intel-unix-abi } " is used by the Intel Fortran Compiler on Linux and Mac OS X." }
- { { $subsection intel-windows-abi } " is used by the Intel Fortran Compiler on Windows." }
+ { { $link gfortran-abi } " is used by gfortran, the Fortran compiler included with GCC 4." }
+ { { $link f2c-abi } " is used by the F2C Fortran-to-C translator and G77, the Fortran compiler included with GCC 3.x and earlier. It is also used by gfortran when compiling with the -ff2c flag." }
+ { { $link intel-unix-abi } " is used by the Intel Fortran Compiler on Linux and Mac OS X." }
+ { { $link intel-windows-abi } " is used by the Intel Fortran Compiler on Windows." }
}
"A library's ABI is specified when that library is opened by the " { $link add-fortran-library } " word." ;
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax io.streams.string assocs
-heaps.private ;
-IN: assoc-heaps
-
-HELP: <assoc-heap>
-{ $values { "assoc" assoc } { "heap" heap } { "assoc-heap" assoc-heap } }
-{ $description "Constructs a new " { $link assoc-heap } " from two existing data structures." } ;
-
-HELP: <unique-max-heap>
-{ $values { "unique-heap" assoc-heap } }
-{ $description "Creates a new " { $link assoc-heap } " where the assoc is a hashtable and the heap is a max-heap. Popping an element from the heap leaves this element in the hashtable to ensure that the element will not be processed again." } ;
-
-HELP: <unique-min-heap>
-{ $values { "unique-heap" assoc-heap } }
-{ $description "Creates a new " { $link assoc-heap } " where the assoc is a hashtable and the heap is a min-heap. Popping an element from the heap leaves this element in the hashtable to ensure that the element will not be processed again." } ;
-
-{ <unique-max-heap> <unique-min-heap> } related-words
-
-HELP: assoc-heap
-{ $description "A data structure containing an assoc and a heap to get certain properties with better time constraints at the expense of more space and complexity. For instance, a hashtable and a heap can be combined into one assoc-heap to get a sorted data structure with O(1) lookup. Operations on assoc-heap may update both the assoc and the heap or leave them out of sync if it's advantageous." } ;
-
-ARTICLE: "assoc-heaps" "Associative heaps"
-"The " { $vocab-link "assoc-heaps" } " vocabulary combines exists to synthesize data structures with better time properties than either of the two component data structures alone." $nl
-"Associative heap constructor:"
-{ $subsection <assoc-heap> }
-"Unique heaps:"
-{ $subsection <unique-min-heap> }
-{ $subsection <unique-max-heap> } ;
-
-ABOUT: "assoc-heaps"
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test assoc-heaps ;
-IN: assoc-heaps.tests
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs hashtables heaps kernel ;
-IN: assoc-heaps
-
-TUPLE: assoc-heap assoc heap ;
-
-C: <assoc-heap> assoc-heap
-
-: <unique-min-heap> ( -- unique-heap )
- H{ } clone <min-heap> <assoc-heap> ;
-
-: <unique-max-heap> ( -- unique-heap )
- H{ } clone <max-heap> <assoc-heap> ;
-
-M: assoc-heap heap-push* ( value key assoc-heap -- entry )
- pick over assoc>> key? [
- 3drop f
- ] [
- [ assoc>> swapd set-at ] [ heap>> heap-push* ] 3bi
- ] if ;
-
-M: assoc-heap heap-pop ( assoc-heap -- value key )
- heap>> heap-pop ;
-
-M: assoc-heap heap-peek ( assoc-heap -- value key )
- heap>> heap-peek ;
-
-M: assoc-heap heap-empty? ( assoc-heap -- value key )
- heap>> heap-empty? ;
+++ /dev/null
-Doug Coleman
\ No newline at end of file
+++ /dev/null
-Priority queue with fast insertion, removal of first element, and lookup of arbitrary elements by key
{ [ 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
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.functions namespaces sequences
-strings system vocabs.loader threads accessors combinators
-locals classes.tuple math.order summary combinators.short-circuit ;
+USING: accessors arrays classes.tuple combinators combinators.short-circuit
+ kernel locals math math.functions math.order namespaces sequences strings
+ summary system threads vocabs.loader ;
IN: calendar
HOOK: gmt-offset os ( -- hours minutes seconds )
GENERIC: leap-year? ( obj -- ? )
M: integer leap-year? ( year -- ? )
- dup 100 mod zero? 400 4 ? mod zero? ;
+ dup 100 divisor? 400 4 ? divisor? ;
M: timestamp leap-year? ( timestamp -- ? )
year>> leap-year? ;
#! good for any date since October 15, 1582
[
dup 2 <= [ [ 1- ] [ 12 + ] bi* ] when
- [ dup [ 4 /i + ] keep [ 100 /i - ] keep 400 /i + ] dip
+ [ dup [ 4 /i + ] [ 100 /i - ] [ 400 /i + ] tri ] dip
[ 1+ 3 * 5 /i + ] keep 2 * +
] dip 1+ + 7 mod ;
! 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
stack-checker math ;
IN: combinators.smart
+MACRO: drop-outputs ( quot -- quot' )
+ dup infer out>> '[ @ _ ndrop ] ;
+
MACRO: output>sequence ( quot exemplar -- newquot )
[ dup infer out>> ] dip
'[ @ _ _ nsequence ] ;
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 )
[
\ 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
! 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
: prepare-CFString ( string -- byte-array )
[
dup HEX: 10ffff >
- [ drop CHAR: replacement-character ] when
+ [ drop HEX: fffd ] when
] map utf8 encode ;
: <CFString> ( string -- alien )
M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
-M: ppc return-struct-in-registers? ( c-type -- ? ) drop f ;
-
-M: ppc %box-small-struct
- drop "No small structs" throw ;
-
-M: ppc %unbox-small-struct
- drop "No small structs" throw ;
+M: ppc return-struct-in-registers? ( c-type -- ? )
+ c-type return-in-registers?>> ;
+
+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 ;
+
+: %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
{ [ os macosx? ] [ "cpu.ppc.macosx" require ] }
{ [ os linux? ] [ "cpu.ppc.linux" require ] }
} cond
+
+"complex-double" c-type t >>return-in-registers? drop
USING: tools.test namespaces documents documents.elements multiline ;
IN: document.elements.tests
-<document> "doc" set
-"123\nabc" "doc" get set-doc-string
+SYMBOL: doc
+<document> doc set
+"123\nabcé" doc get set-doc-string
! char-elt
-[ { 0 0 } ] [ { 0 0 } "doc" get char-elt prev-elt ] unit-test
-[ { 0 0 } ] [ { 0 1 } "doc" get char-elt prev-elt ] unit-test
-[ { 0 3 } ] [ { 1 0 } "doc" get char-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 0 } doc get char-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 1 } doc get char-elt prev-elt ] unit-test
+[ { 0 3 } ] [ { 1 0 } doc get char-elt prev-elt ] unit-test
+[ { 1 3 } ] [ { 1 5 } doc get char-elt prev-elt ] unit-test
-[ { 1 3 } ] [ { 1 3 } "doc" get char-elt next-elt ] unit-test
-[ { 0 2 } ] [ { 0 1 } "doc" get char-elt next-elt ] unit-test
-[ { 1 0 } ] [ { 0 3 } "doc" get char-elt next-elt ] unit-test
+[ { 1 5 } ] [ { 1 5 } doc get char-elt next-elt ] unit-test
+[ { 0 2 } ] [ { 0 1 } doc get char-elt next-elt ] unit-test
+[ { 1 0 } ] [ { 0 3 } doc get char-elt next-elt ] unit-test
+[ { 1 5 } ] [ { 1 3 } doc get char-elt next-elt ] unit-test
! word-elt
-<document> "doc" set
-"Hello world\nanother line" "doc" get set-doc-string
+<document> doc set
+"Hello world\nanother line" doc get set-doc-string
-[ { 0 0 } ] [ { 0 0 } "doc" get word-elt prev-elt ] unit-test
-[ { 0 0 } ] [ { 0 2 } "doc" get word-elt prev-elt ] unit-test
-[ { 0 0 } ] [ { 0 5 } "doc" get word-elt prev-elt ] unit-test
-[ { 0 5 } ] [ { 0 6 } "doc" get word-elt prev-elt ] unit-test
-[ { 0 6 } ] [ { 0 8 } "doc" get word-elt prev-elt ] unit-test
-[ { 0 11 } ] [ { 1 0 } "doc" get word-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 0 } doc get word-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 2 } doc get word-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 5 } doc get word-elt prev-elt ] unit-test
+[ { 0 5 } ] [ { 0 6 } doc get word-elt prev-elt ] unit-test
+[ { 0 6 } ] [ { 0 8 } doc get word-elt prev-elt ] unit-test
+[ { 0 11 } ] [ { 1 0 } doc get word-elt prev-elt ] unit-test
+
+[ { 0 5 } ] [ { 0 0 } doc get word-elt next-elt ] unit-test
+[ { 0 6 } ] [ { 0 5 } doc get word-elt next-elt ] unit-test
+[ { 0 11 } ] [ { 0 6 } doc get word-elt next-elt ] unit-test
+[ { 1 0 } ] [ { 0 11 } doc get word-elt next-elt ] unit-test
-[ { 0 5 } ] [ { 0 0 } "doc" get word-elt next-elt ] unit-test
-[ { 0 6 } ] [ { 0 5 } "doc" get word-elt next-elt ] unit-test
-[ { 0 11 } ] [ { 0 6 } "doc" get word-elt next-elt ] unit-test
-[ { 1 0 } ] [ { 0 11 } "doc" get word-elt next-elt ] unit-test
! one-word-elt
-[ { 0 0 } ] [ { 0 0 } "doc" get one-word-elt prev-elt ] unit-test
-[ { 0 0 } ] [ { 0 2 } "doc" get one-word-elt prev-elt ] unit-test
-[ { 0 0 } ] [ { 0 5 } "doc" get one-word-elt prev-elt ] unit-test
-[ { 0 5 } ] [ { 0 2 } "doc" get one-word-elt next-elt ] unit-test
-[ { 0 5 } ] [ { 0 5 } "doc" get one-word-elt next-elt ] unit-test
+[ { 0 0 } ] [ { 0 0 } doc get one-word-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 2 } doc get one-word-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 5 } doc get one-word-elt prev-elt ] unit-test
+[ { 0 5 } ] [ { 0 2 } doc get one-word-elt next-elt ] unit-test
+[ { 0 5 } ] [ { 0 5 } doc get one-word-elt next-elt ] unit-test
! line-elt
-<document> "doc" set
-"Hello\nworld, how are\nyou?" "doc" get set-doc-string
+<document> doc set
+"Hello\nworld, how are\nyou?" doc get set-doc-string
-[ { 0 0 } ] [ { 0 3 } "doc" get line-elt prev-elt ] unit-test
-[ { 0 3 } ] [ { 1 3 } "doc" get line-elt prev-elt ] unit-test
-[ { 2 4 } ] [ { 2 1 } "doc" get line-elt next-elt ] unit-test
+[ { 0 0 } ] [ { 0 3 } doc get line-elt prev-elt ] unit-test
+[ { 0 3 } ] [ { 1 3 } doc get line-elt prev-elt ] unit-test
+[ { 2 4 } ] [ { 2 1 } doc get line-elt next-elt ] unit-test
! one-line-elt
-[ { 1 0 } ] [ { 1 3 } "doc" get one-line-elt prev-elt ] unit-test
-[ { 1 14 } ] [ { 1 3 } "doc" get one-line-elt next-elt ] unit-test
+[ { 1 0 } ] [ { 1 3 } doc get one-line-elt prev-elt ] unit-test
+[ { 1 14 } ] [ { 1 3 } doc get one-line-elt next-elt ] unit-test
! page-elt
-<document> "doc" set
+<document> doc set
<" First line
Second line
Third line
Fourth line
Fifth line
-Sixth line"> "doc" get set-doc-string
+Sixth line"> doc get set-doc-string
-[ { 0 0 } ] [ { 3 3 }
"doc" get 4 <page-elt> prev-elt ] unit-test
-[ { 1 2 } ] [ { 5 2 }
"doc" get 4 <page-elt> prev-elt ] unit-test
+[ { 0 0 } ] [ { 3 3 }
doc get 4 <page-elt> prev-elt ] unit-test
+[ { 1 2 } ] [ { 5 2 }
doc get 4 <page-elt> prev-elt ] unit-test
-[ { 4 3 } ] [ { 0 3 }
"doc" get 4 <page-elt> next-elt ] unit-test
-[ { 5 10 } ] [ { 4 2 }
"doc" get 4 <page-elt> next-elt ] unit-test
+[ { 4 3 } ] [ { 0 3 }
doc get 4 <page-elt> next-elt ] unit-test
+[ { 5 10 } ] [ { 4 2 }
doc get 4 <page-elt> next-elt ] unit-test
! doc-elt
-[ { 0 0 } ] [ { 3 4 } "doc" get doc-elt prev-elt ] unit-test
-[ { 5 10 } ] [ { 3 4 } "doc" get doc-elt next-elt ] unit-test
\ No newline at end of file
+[ { 0 0 } ] [ { 3 4 } doc get doc-elt prev-elt ] unit-test
+[ { 5 10 } ] [ { 3 4 } doc get doc-elt next-elt ] unit-test
! 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 )
<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
<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>
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
M: doc-elt prev-elt 3drop { 0 0 } ;
-M: doc-elt next-elt drop nip doc-end ;
\ No newline at end of file
+M: doc-elt next-elt drop nip doc-end ;
[ "<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 [
] if
] if ;
-: take-until ( state delimiter -- string/f state' )
+: take-until ( state delimiter -- string state'/f )
V{ } clone (take-until) ;
: count= ( string -- n )
: 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 )
: help>html ( topic -- xml )
[ article-title ]
[ drop help-stylesheet ]
- [ [ help ] with-html-writer ]
+ [ [ print-topic ] with-html-writer ]
tri simple-page ;
: generate-help-file ( topic -- )
IN: help.tips
USING: help.markup help.syntax debugger prettyprint see help help.vocabs
-help.apropos tools.time stack-checker editors ;
+help.apropos tools.time stack-checker editors memory ;
TIP: "To look at the most recent error, run " { $link :error } ". To look at the most recent error's callstack, run " { $link :c } "." ;
TIP: "Tips of the day implement the " { $link "definition-protocol" } " and new tips of the day can be defined using the " { $link POSTPONE: TIP: } " parsing word." ;
+TIP: "Try some simple demo applications, then look at the source code in " { $snippet "extra/" } ": " { $snippet "\"demos\" run" } ;
+
+TIP: "To save time on reloading big libraries such as the " { $vocab-link "furnace" } " web framework, save the image after loading them using the " { $link save } " word." ;
+
HELP: TIP:
{ $syntax "TIP: content ;" }
{ $values { "content" "a markup element" } }
\ >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
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel ;
+USING: combinators kernel accessors ;
IN: images
SINGLETONS: L BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
+UNION: alpha-channel BGRA RGBA ABGR ARGB R16G16B16A16 R32G32B32A32 ;
+
: bytes-per-pixel ( component-order -- n )
{
{ L [ 1 ] }
: <image> ( -- image ) image new ; inline
+: has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
+
GENERIC: load-image* ( path tuple -- image )
\ No newline at end of file
M: ABGR normalize-component-order*
drop ARGB>RGBA BGRA>RGBA ;
+: fix-XBGR ( bitmap -- bitmap' )
+ dup 4 <sliced-groups> [ [ 255 0 ] dip set-nth ] each ;
+
+M: XBGR normalize-component-order*
+ drop fix-XBGR ABGR normalize-component-order* ;
+
+: fix-BGRX ( bitmap -- bitmap' )
+ dup 4 <sliced-groups> [ [ 255 3 ] dip set-nth ] each ;
+
+M: BGRX normalize-component-order*
+ drop fix-BGRX BGRA normalize-component-order* ;
+
: normalize-scan-line-order ( image -- image )
dup upside-down?>> [
dup dim>> first 4 * '[
! 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
128 encode-if< ;
M: ascii decode-char
- 128 decode-if< ;
-
-ascii "ANSI_X3.4-1968" register-encoding
+ 128 decode-if< ;
\ No newline at end of file
! 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
[ 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
--- /dev/null
+USING: alien.fortran help.markup help.syntax math.blas.config multiline ;
+IN: math.blas.config
+
+ARTICLE: "math.blas.config" "Configuring the BLAS interface"
+"The " { $link "math.blas-summary" } " chooses the underlying BLAS interface to use based on the values of the following global variables:"
+{ $subsection blas-library }
+{ $subsection blas-fortran-abi }
+"The interface attempts to set default values based on the ones encountered on the Factor project's build machines. If these settings don't work with your system's BLAS, or you wish to use a commercial BLAS, you may change the global values of those variables in your " { $link "factor-rc" } ". For example, to use AMD's ACML library on Windows with " { $snippet "math.blas" } ", your " { $snippet "factor-rc" } " would look like this:"
+{ $code <"
+USING: math.blas.config namespaces ;
+"X:\\path\\to\\acml.dll" blas-library set-global
+intel-windows-abi blas-fortran-abi set-global
+"> }
+"To take effect, the " { $snippet "blas-library" } " and " { $snippet "blas-fortran-abi" } " variables must be set before any other " { $snippet "math.blas" } " vocabularies are loaded."
+;
+
+HELP: blas-library
+{ $description "The name of the shared library containing the BLAS interface to load. The value of this variable must be a valid shared library name that can be passed to " { $link add-fortran-library } ". To take effect, this variable must be set before any other " { $snippet "math.blas" } " vocabularies are loaded. See " { $link "math.blas.config" } " for details and examples." } ;
+
+HELP: blas-fortran-abi
+{ $description "The Fortran ABI used by the BLAS interface specified in the " { $link blas-library } " variable. The value of " { $snippet "blas-fortran-abi" } " must be one of the " { $link "alien.fortran-abis" } " that can be passed to " { $link add-fortran-library } ". To take effect, this variable must be set before any other " { $snippet "math.blas" } " vocabularies are loaded. See " { $link "math.blas.config" } " for details and examples." } ;
+
+ABOUT: "math.blas.config"
--- /dev/null
+USING: alien.fortran combinators kernel namespaces system ;
+IN: math.blas.config
+
+SYMBOLS: blas-library blas-fortran-abi ;
+
+blas-library [
+ {
+ { [ os macosx? ] [ "libblas.dylib" ] }
+ { [ os windows? ] [ "blas.dll" ] }
+ [ "libblas.so" ]
+ } cond
+] initialize
+
+blas-fortran-abi [
+ {
+ { [ os macosx? ] [ intel-unix-abi ] }
+ { [ os windows? cpu x86.32? and ] [ f2c-abi ] }
+ { [ os windows? cpu x86.64? and ] [ gfortran-abi ] }
+ { [ os freebsd? ] [ gfortran-abi ] }
+ { [ os linux? cpu x86.32? and ] [ gfortran-abi ] }
+ [ f2c-abi ]
+ } cond
+] initialize
-USING: alien alien.fortran kernel system combinators
-alien.libraries ;
+USING: alien.fortran kernel math.blas.config namespaces ;
IN: math.blas.ffi
<<
-"blas" {
- { [ os macosx? ] [ "libblas.dylib" intel-unix-abi add-fortran-library ] }
- { [ os windows? cpu x86.32? and ] [ "blas.dll" f2c-abi add-fortran-library ] }
- { [ os windows? cpu x86.64? and ] [ "blas.dll" gfortran-abi add-fortran-library ] }
- {
- [ os [ freebsd? ] [ linux? cpu x86.32? and ] bi or ]
- [ "libblas.so" gfortran-abi add-fortran-library ]
- }
- { [ os [ freebsd? ] [ linux? ] bi or ] [ "libblas.so" gfortran-abi add-fortran-library ] }
- [ "libblas.so" f2c-abi add-fortran-library ]
-} cond
+"blas" blas-library blas-fortran-abi [ get ] bi@
+add-fortran-library
>>
LIBRARY: blas
IN: math.blas.matrices
ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface"
-"Factor provides an interface to high-performance vector and matrix math routines available in the system's BLAS library. A set of specialized types are provided for handling packed, unboxed vector data:"
+"Factor provides an interface to high-performance vector and matrix math routines available in implementations of the BLAS math library. A set of specialized types are provided for handling packed, unboxed vector data:"
{ $subsection "math.blas-types" }
"Scalar-vector and vector-vector operations are available in the " { $vocab-link "math.blas.vectors" } " vocabulary:"
{ $subsection "math.blas.vectors" }
"Vector-matrix and matrix-matrix operations are available in the " { $vocab-link "math.blas.matrices" } " vocabulary:"
{ $subsection "math.blas.matrices" }
-"The low-level BLAS Fortran interface can be accessed directly through the " { $vocab-link "math.blas.ffi" } " vocabulary." ;
+"The low-level BLAS Fortran interface can be accessed directly through the " { $vocab-link "math.blas.ffi" } " vocabulary. The BLAS interface can be configured to use different underlying BLAS implementations:"
+{ $subsection "math.blas.config" } ;
ARTICLE: "math.blas-types" "BLAS interface types"
"BLAS vectors come in single- and double-precision, real and complex flavors:"
"Tests:"
{ $subsection power-of-2? }
{ $subsection even? }
-{ $subsection odd? } ;
+{ $subsection odd? }
+{ $subsection divisor? } ;
ARTICLE: "arithmetic-functions" "Arithmetic functions"
"Computing additive and multiplicative inverses:"
{ $description "Computes the positive greatest common divisor " { $snippet "d" } " of " { $snippet "x" } " and " { $snippet "y" } ", and another value " { $snippet "a" } " satisfying:" { $code "a*y = d mod x" } }
{ $notes "If " { $snippet "d" } " is 1, then " { $snippet "a" } " is the inverse of " { $snippet "y" } " modulo " { $snippet "x" } "." } ;
+HELP: divisor?
+{ $values { "m" integer } { "n" integer } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "n" } " is a divisor of " { $snippet "m" } ". This is the same thing as asking if " { $snippet "m" } " is divisible by " { $snippet "n" } "." }
+{ $notes "Returns t for both negative and positive divisors, as well as for trivial and non-trivial divisors." } ;
+
HELP: mod-inv
{ $values { "x" integer } { "n" integer } { "y" integer } }
{ $description "Outputs an integer " { $snippet "y" } " such that " { $snippet "xy = 1 (mod n)" } "." }
[ 1.0 ] [ 0 cosh ] unit-test
[ 0.0 ] [ 1 acosh ] unit-test
-
+
[ 1.0 ] [ 0 cos ] unit-test
[ 0.0 ] [ 1 acos ] unit-test
-
+
[ 0.0 ] [ 0 sinh ] unit-test
[ 0.0 ] [ 0 asinh ] unit-test
-
+
[ 0.0 ] [ 0 sin ] unit-test
[ 0.0 ] [ 0 asin ] unit-test
: verify-gcd ( a b -- ? )
2dup gcd
- [ rot * swap rem ] dip = ;
+ [ rot * swap rem ] dip = ;
[ t ] [ 123 124 verify-gcd ] unit-test
[ t ] [ 50 120 verify-gcd ] unit-test
+[ t ] [ 0 42 divisor? ] unit-test
+[ t ] [ 42 7 divisor? ] unit-test
+[ t ] [ 42 -7 divisor? ] unit-test
+[ t ] [ 42 42 divisor? ] unit-test
+[ f ] [ 42 16 divisor? ] unit-test
+
[ 3 ] [ 5 7 mod-inv ] unit-test
[ 78572682077 ] [ 234829342 342389423843 mod-inv ] unit-test
1067811677921310779
2135623355842621559
[ >bignum ] tri@ ^mod
-] unit-test
\ No newline at end of file
+] unit-test
: lcm ( a b -- c )
[ * ] 2keep gcd nip /i ; foldable
+: divisor? ( m n -- ? )
+ mod 0 = ;
+
: mod-inv ( x n -- y )
[ nip ] [ gcd 1 = ] 2bi
[ dup 0 < [ + ] [ nip ] if ]
GENERIC: sinh ( x -- y ) foldable
-M: complex sinh
+M: complex sinh
>float-rect
[ [ fsinh ] [ fcos ] bi* * ]
[ [ fcosh ] [ fsin ] bi* * ] 2bi rect> ;
! Copyright (C) 2007-2009 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators kernel make math math.primes sequences ;
+USING: arrays combinators kernel make math math.functions math.primes sequences ;
IN: math.primes.factors
<PRIVATE
swap ;
: write-factor ( n d -- n' d' )
- 2dup mod zero? [
+ 2dup divisor? [
[ [ count-factor ] keep swap 2array , ] keep
! If the remainder is a prime number, increase d so that
! the caller stops looking for factors.
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>
USING: accessors assocs cache colors.constants destructors fry kernel
opengl opengl.gl combinators images images.tesselation grouping
specialized-arrays.float locals sequences math math.vectors
-math.matrices generalizations fry columns ;
+math.matrices generalizations fry columns arrays ;
IN: opengl.textures
: gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ;
M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ;
M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ;
M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
+M: BGRX component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
GENERIC: draw-texture ( texture -- )
<PRIVATE
-TUPLE: single-texture loc dim texture-coords texture display-list disposed ;
+TUPLE: single-texture image loc dim texture-coords texture display-list disposed ;
: repeat-last ( seq n -- seq' )
over peek pad-tail concat ;
tri * group ; inline
: power-of-2-image ( image -- image )
- dup dim>> [ 0 = ] all? [
+ dup dim>> [ [ 0 = ] [ power-of-2? ] bi or ] all? [
clone dup
[ image-rows ]
[ dim>> [ next-power-of-2 ] map ]
: draw-textured-rect ( dim texture -- )
[
- (draw-textured-rect)
- GL_TEXTURE_2D 0 glBindTexture
+ [ image>> has-alpha? [ GL_BLEND glDisable ] unless ]
+ [ (draw-textured-rect) GL_TEXTURE_2D 0 glBindTexture ]
+ [ image>> has-alpha? [ GL_BLEND glEnable ] unless ]
+ tri
] with-texturing ;
-: texture-coords ( dim -- coords )
- [ dup next-power-of-2 /f ] map
- { { 0 0 } { 1 0 } { 1 1 } { 0 1 } } [ v* ] with map
+: texture-coords ( texture -- coords )
+ [
+ [ dim>> ] [ image>> dim>> ] bi v/
+ { { 0 0 } { 1 0 } { 1 1 } { 0 1 } }
+ [ v* ] with map
+ ] keep
+ image>> upside-down?>> [ [ first2 1 swap - 2array ] map ] when
float-array{ } join ;
: make-texture-display-list ( texture -- dlist )
GL_COMPILE [ [ dim>> ] keep draw-textured-rect ] make-dlist ;
-: <single-texture> ( image loc -- texture )
- single-texture new swap >>loc
- swap
- [ dim>> >>dim ] keep
- [ dim>> product 0 = ] keep '[
- _
- [ dim>> texture-coords >>texture-coords ]
- [ power-of-2-image make-texture >>texture ] bi
+: <single-texture> ( image loc dim -- texture )
+ [ power-of-2-image ] 2dip
+ single-texture new swap >>dim swap >>loc swap >>image
+ dup image>> dim>> product 0 = [
+ dup texture-coords >>texture-coords
+ dup image>> make-texture >>texture
dup make-texture-display-list >>display-list
] unless ;
: <texture-grid> ( image-grid loc -- grid )
[ dup image-locs ] dip
- '[ [ _ v+ <single-texture> |dispose ] 2map ] 2map ;
+ '[ [ _ v+ over dim>> <single-texture> |dispose ] 2map ] 2map ;
: draw-textured-grid ( grid -- )
[ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ;
+: grid-has-alpha? ( grid -- ? )
+ first first image>> has-alpha? ;
+
: make-textured-grid-display-list ( grid -- dlist )
GL_COMPILE [
[
- [
- [
- [ dim>> ] keep (draw-textured-rect)
- ] each
- ] each
+ [ grid-has-alpha? [ GL_BLEND glDisable ] unless ]
+ [ [ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ]
+ [ grid-has-alpha? [ GL_BLEND glEnable ] unless ] tri
GL_TEXTURE_2D 0 glBindTexture
] with-texturing
] make-dlist ;
M: multi-texture dispose* grid>> [ [ dispose ] each ] each ;
-CONSTANT: max-texture-size { 256 256 }
+CONSTANT: max-texture-size { 512 512 }
PRIVATE>
-: <texture> ( image loc -- texture )
- over dim>> max-texture-size [ <= ] 2all?
+: small-texture? ( dim -- ? )
+ max-texture-size [ <= ] 2all? ;
+
+: <texture> ( image loc dim -- texture )
+ pick dim>> small-texture?
[ <single-texture> ]
- [ [ max-texture-size tesselate ] dip <multi-texture> ] if ;
\ No newline at end of file
+ [ drop [ max-texture-size tesselate ] dip <multi-texture> ] if ;
\ No newline at end of file
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays assocs byte-arrays io
io.binary io.streams.string kernel math math.parser namespaces
-make parser prettyprint quotations sequences strings vectors
+make parser quotations sequences strings vectors
words macros math.functions math.bitwise fry generalizations
combinators.smart io.streams.byte-array io.encodings.binary
math.vectors combinators multiline endian ;
!
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" } } [
{ "\\" } [
"\\" [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
continuations peg peg.parsers unicode.categories multiline\r
splitting accessors effects sequences.deep peg.search\r
combinators.short-circuit lexer io.streams.string stack-checker\r
-io combinators parser ;\r
+io combinators parser summary ;\r
IN: peg.ebnf\r
\r
: rule ( name word -- parser )\r
#! Given an EBNF word produced from EBNF: return the EBNF rule\r
"ebnf-parser" word-prop at ;\r
\r
+ERROR: no-rule rule parser ;\r
+\r
+: lookup-rule ( rule parser -- rule' )\r
+ 2dup rule [ 2nip ] [ no-rule ] if* ; \r
+\r
TUPLE: tokenizer any one many ;\r
\r
: default-tokenizer ( -- tokenizer )\r
: reset-tokenizer ( -- )\r
default-tokenizer \ tokenizer set-global ;\r
\r
+ERROR: no-tokenizer name ;\r
+\r
+M: no-tokenizer summary\r
+ drop "Tokenizer not found" ;\r
+\r
SYNTAX: TOKENIZER: \r
- scan search [ "Tokenizer not found" throw ] unless*\r
+ scan dup search [ nip ] [ no-tokenizer ] if*\r
execute( -- tokenizer ) \ tokenizer set-global ;\r
\r
TUPLE: ebnf-non-terminal symbol ;\r
"]]" token ensure-not ,\r
"]?" token ensure-not ,\r
[ drop t ] satisfy ,\r
- ] seq* [ first ] action repeat0 [ >string ] action ;\r
+ ] seq* repeat0 [ concat >string ] action ;\r
\r
: 'ensure-not' ( -- parser )\r
#! Parses the '!' syntax to ensure that \r
(transform) \r
dup parser-tokenizer \ tokenizer set-global\r
] if ;\r
+\r
+ERROR: redefined-rule name ;\r
+\r
+M: redefined-rule summary\r
+ name>> "Rule '" "' defined more than once" surround ;\r
\r
M: ebnf-rule (transform) ( ast -- parser )\r
dup elements>> \r
(transform) [\r
- swap symbol>> dup get parser? [ \r
- "Rule '" over append "' defined more than once" append throw \r
- ] [ \r
- set \r
- ] if\r
+ swap symbol>> dup get parser? [ redefined-rule ] [ set ] if\r
] keep ;\r
\r
M: ebnf-sequence (transform) ( ast -- parser )\r
{ [ dup (( -- b )) effect<= ] [ drop [ drop ] prepose ] }\r
[ bad-effect ]\r
} cond ;\r
+\r
+: ebnf-transform ( ast -- parser quot )\r
+ [ parser>> (transform) ]\r
+ [ code>> insert-escapes ]\r
+ [ parser>> ] tri build-locals \r
+ [ string-lines parse-lines ] call( string -- quot ) ;\r
\r
M: ebnf-action (transform) ( ast -- parser )\r
- [ parser>> (transform) ] [ code>> insert-escapes ] [ parser>> ] tri build-locals \r
- [ string-lines parse-lines ] call( string -- quot ) check-action-effect action ;\r
+ ebnf-transform check-action-effect action ;\r
\r
M: ebnf-semantic (transform) ( ast -- parser )\r
- [ parser>> (transform) ] [ code>> insert-escapes ] [ parser>> ] tri build-locals \r
- [ string-lines parse-lines ] call( string -- quot ) semantic ;\r
+ ebnf-transform semantic ;\r
\r
M: ebnf-var (transform) ( ast -- parser )\r
parser>> (transform) ;\r
M: ebnf-terminal (transform) ( ast -- parser )\r
symbol>> tokenizer one>> call( symbol -- parser ) ;\r
\r
+ERROR: ebnf-foreign-not-found name ;\r
+\r
+M: ebnf-foreign-not-found summary\r
+ name>> "Foreign word '" "' not found" surround ;\r
+\r
M: ebnf-foreign (transform) ( ast -- parser )\r
- dup word>> search\r
- [ "Foreign word '" swap word>> append "' not found" append throw ] unless*\r
+ dup word>> search [ word>> ebnf-foreign-not-found ] unless*\r
swap rule>> [ main ] unless* over rule [\r
nip\r
] [\r
execute( -- parser )\r
] if* ;\r
\r
-: parser-not-found ( name -- * )\r
- [\r
- "Parser '" % % "' not found." %\r
- ] "" make throw ;\r
+ERROR: parser-not-found name ;\r
\r
M: ebnf-non-terminal (transform) ( ast -- parser )\r
symbol>> [\r
'ebnf' parse transform ;\r
\r
: check-parse-result ( result -- result )\r
- dup [\r
- dup remaining>> [ blank? ] trim empty? [\r
+ [\r
+ dup remaining>> [ blank? ] trim [\r
[ \r
"Unable to fully parse EBNF. Left to parse was: " %\r
remaining>> % \r
] "" make throw\r
- ] unless\r
+ ] unless-empty\r
] [\r
"Could not parse EBNF" throw\r
- ] if ;\r
+ ] if* ;\r
\r
: parse-ebnf ( string -- hashtable )\r
'ebnf' (parse) check-parse-result ast>> transform ;\r
parse-ebnf dup dup parser [ main swap at compile ] with-variable\r
[ compiled-parse ] curry [ with-scope ast>> ] curry ;\r
\r
-SYNTAX: <EBNF "EBNF>" reset-tokenizer parse-multiline-string parse-ebnf main swap at \r
+SYNTAX: <EBNF\r
+ "EBNF>"\r
+ reset-tokenizer parse-multiline-string parse-ebnf main swap at \r
parsed reset-tokenizer ;\r
\r
-SYNTAX: [EBNF "EBNF]" reset-tokenizer parse-multiline-string ebnf>quot nip \r
+SYNTAX: [EBNF\r
+ "EBNF]"\r
+ reset-tokenizer parse-multiline-string ebnf>quot nip \r
parsed \ call parsed reset-tokenizer ;\r
\r
SYNTAX: EBNF: \r
reset-tokenizer CREATE-WORD dup ";EBNF" parse-multiline-string \r
- ebnf>quot swapd (( input -- ast )) define-declared "ebnf-parser" set-word-prop \r
+ ebnf>quot swapd\r
+ (( input -- ast )) define-declared "ebnf-parser" set-word-prop \r
reset-tokenizer ;\r
-\r
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* |
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
--- /dev/null
+! 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
{ } 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 )
: 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 )
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: functors kernel math.order sequences sorting ;
+IN: sorting.functor
+
+FUNCTOR: define-sorting ( NAME QUOT -- )
+
+NAME<=> DEFINES ${NAME}<=>
+NAME>=< DEFINES ${NAME}>=<
+
+WHERE
+
+: NAME<=> ( obj1 obj2 -- <=> ) QUOT bi@ <=> ;
+: NAME>=< ( obj1 obj2 -- >=< ) NAME<=> invert-comparison ;
+
+;FUNCTOR
}
{ $description "Compares two objects using the " { $link human<=> } " word and inverts the result." } ;
-HELP: human-compare
-{ $values
- { "obj1" object } { "obj2" object } { "quot" quotation }
- { "<=>" "an ordering specifier" }
-}
-{ $description "Compares the results of applying the quotation to both objects via <=>." } ;
-
-HELP: human-sort
-{ $values
- { "seq" sequence }
- { "seq'" sequence }
-}
-{ $description "Sorts a sequence of objects by comparing the magnitude of any integers in the input string using the <=> word." } ;
-
-HELP: human-sort-keys
-{ $values
- { "seq" "an alist" }
- { "sortedseq" "a new sorted sequence" }
-}
-{ $description "Sorts the elements comparing first elements of pairs using the " { $link human<=> } " word." } ;
-
-HELP: human-sort-values
-{ $values
- { "seq" "an alist" }
- { "sortedseq" "a new sorted sequence" }
-}
-{ $description "Sorts the elements comparing second elements of pairs using the " { $link human<=> } " word." } ;
-
-{ <=> >=< human-compare human-sort human-sort-keys human-sort-values } related-words
-
ARTICLE: "sorting.human" "Human-friendly sorting"
"The " { $vocab-link "sorting.human" } " vocabulary sorts by numbers as a human would -- by comparing their magnitudes -- rather than in a lexicographic way. For example, sorting a1, a10, a03, a2 with human sort returns a1, a2, a03, a10, while sorting with natural sort returns a03, a1, a10, a2." $nl
"Comparing two objects:"
{ $subsection human<=> }
{ $subsection human>=< }
-{ $subsection human-compare }
-"Sort a sequence:"
-{ $subsection human-sort }
-{ $subsection human-sort-keys }
-{ $subsection human-sort-values }
"Splitting a string into substrings and integers:"
{ $subsection find-numbers } ;
-USING: sorting.human tools.test ;
+USING: sorting.human tools.test sorting.slots ;
IN: sorting.human.tests
-\ human-sort must-infer
-
-[ { "x1y" "x2" "x10y" } ] [ { "x1y" "x10y" "x2" } human-sort ] unit-test
+[ { "x1y" "x2" "x10y" } ] [ { "x1y" "x10y" "x2" } { human<=> } sort-by ] unit-test
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: peg.ebnf math.parser kernel assocs sorting fry
-math.order sequences ascii splitting.monotonic ;
+USING: math.parser peg.ebnf sorting.functor ;
IN: sorting.human
: find-numbers ( string -- seq )
[EBNF Result = ([0-9]+ => [[ string>number ]] | (!([0-9]) .)+)* EBNF] ;
-: human<=> ( obj1 obj2 -- <=> ) [ find-numbers ] bi@ <=> ;
-
-: human>=< ( obj1 obj2 -- >=< ) human<=> invert-comparison ; inline
-
-: human-compare ( obj1 obj2 quot -- <=> ) bi@ human<=> ;
-
-: human-sort ( seq -- seq' ) [ human<=> ] sort ;
-
-: human-sort-keys ( seq -- sortedseq )
- [ [ first ] human-compare ] sort ;
-
-: human-sort-values ( seq -- sortedseq )
- [ [ second ] human-compare ] sort ;
+<< "human" [ find-numbers ] define-sorting >>
HELP: sort-by-slots
{ $values
{ "seq" sequence } { "sort-specs" "a sequence of accessors ending with a comparator" }
- { "seq'" sequence }
+ { "sortedseq" sequence }
}
{ $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a sequence of slot accessors ending in a comparator." }
{ $examples
}
{ $description "Splits a sequence of tuples into a sequence of slices of tuples that have the same values in all slots in the accessor sequence. This word is only useful for splitting a sorted sequence, but is more efficient than partitioning in such a case." } ;
+HELP: sort-by
+{ $values
+ { "seq" sequence } { "sort-seq" "a sequence of comparators" }
+ { "sortedseq" sequence }
+}
+{ $description "Sorts a sequence by comparing elements by comparators, using subsequent comparators when there is a tie." } ;
+
ARTICLE: "sorting.slots" "Sorting by slots"
"The " { $vocab-link "sorting.slots" } " vocabulary can sort tuples by slot in ascending or descending order, using subsequent slots as tie-breakers." $nl
"Comparing two objects by a sequence of slots:"
{ $subsection compare-slots }
-"Sorting a sequence by a sequence of slots:"
-{ $subsection sort-by-slots } ;
+"Sorting a sequence of tuples by a slot/comparator pairs:"
+{ $subsection sort-by-slots }
+"Sorting a sequence by a sequence of comparators:"
+{ $subsection sort-by } ;
ABOUT: "sorting.slots"
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors math.order sorting.slots tools.test
-sorting.human arrays sequences kernel assocs multiline ;
+sorting.human arrays sequences kernel assocs multiline
+sorting.functor ;
IN: sorting.literals.tests
TUPLE: sort-test a b c tuple2 ;
[ { } ]
[ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots ] unit-test
+[ { } ]
+[ { } { } sort-by-slots ] unit-test
+
[
{
T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 1 } } } }
T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 4 } } } }
} { { tuple2>> d>> } { a>> } } split-by-slots [ >array ] map
] unit-test
+
+
+[ { "a" "b" "c" } ] [ { "b" "c" "a" } { <=> <=> } sort-by ] unit-test
+[ { "b" "c" "a" } ] [ { "b" "c" "a" } { } sort-by ] unit-test
+
+<< "length-test" [ length ] define-sorting >>
+
+[ { { 1 } { 1 2 3 } { 1 3 2 } { 3 2 1 } } ]
+[
+ { { 3 2 1 } { 1 2 3 } { 1 3 2 } { 1 } }
+ { length-test<=> <=> } sort-by
+] unit-test
<PRIVATE
+: short-circuit-comparator ( obj1 obj2 word -- comparator/? )
+ execute dup +eq+ eq? [ drop f ] when ; inline
+
: slot-comparator ( seq -- quot )
[
but-last-slice
[ '[ [ _ execute ] bi@ ] ] map concat
] [
peek
- '[ @ _ execute dup +eq+ eq? [ drop f ] when ]
+ '[ @ _ short-circuit-comparator ]
] bi ;
PRIVATE>
#! sort-spec: { accessors comparator }
[ slot-comparator ] map '[ _ 2|| +eq+ or ] ;
-: sort-by-slots ( seq sort-specs -- seq' )
- '[ _ compare-slots ] sort ;
+MACRO: sort-by-slots ( sort-specs -- quot )
+ '[ [ _ compare-slots ] sort ] ;
+
+MACRO: compare-seq ( seq -- quot )
+ [ '[ _ short-circuit-comparator ] ] map '[ _ 2|| +eq+ or ] ;
+
+MACRO: sort-by ( sort-seq -- quot )
+ '[ [ _ compare-seq ] sort ] ;
+
+MACRO: sort-keys-by ( sort-seq -- quot )
+ '[ [ first ] bi@ _ compare-seq ] sort ;
+
+MACRO: sort-values-by ( sort-seq -- quot )
+ '[ [ second ] bi@ _ compare-seq ] sort ;
MACRO: split-by-slots ( accessor-seqs -- quot )
[ [ '[ [ _ execute ] bi@ ] ] map concat [ = ] compose ] map
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test sorting.title sorting.slots ;
+IN: sorting.title.tests
+
+: sort-me ( -- seq )
+ {
+ "The Beatles"
+ "A river runs through it"
+ "Another"
+ "la vida loca"
+ "Basketball"
+ "racquetball"
+ "Los Fujis"
+ "los Fujis"
+ "La cucaracha"
+ "a day to remember"
+ "of mice and men"
+ "on belay"
+ "for the horde"
+ } ;
+[
+ {
+ "Another"
+ "Basketball"
+ "The Beatles"
+ "La cucaracha"
+ "a day to remember"
+ "for the horde"
+ "Los Fujis"
+ "los Fujis"
+ "of mice and men"
+ "on belay"
+ "racquetball"
+ "A river runs through it"
+ "la vida loca"
+ }
+] [
+ sort-me { title<=> } sort-by
+] unit-test
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sorting.functor regexp kernel accessors sequences
+unicode.case ;
+IN: sorting.title
+
+<< "title" [ >lower dup R/ ^(the|a|an|el|la|los|las|il) / first-match [ to>> tail-slice ] when* ] define-sorting >>
\ fflush { alien } { } define-primitive
+\ fseek { alien integer integer } { } define-primitive
+
\ fclose { alien } { } define-primitive
\ <wrapper> { object } { wrapper } define-primitive
{ $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 } }
{ $subsection <entry> }
"Reading feeds:"
{ $subsection download-feed }
-{ $subsection string>feed }
+{ $subsection parse-feed }
{ $subsection xml>feed }
"Writing feeds:"
{ $subsection feed>xml }
-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
: 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
! 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 )
{ "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
: create-app-dir ( vocab bundle-name -- vm )
[
- nip
- [ copy-dll ]
- [ copy-nib ]
- [ "Contents/Resources" append-path make-directories ]
- tri
+ nip {
+ [ copy-dll ]
+ [ copy-nib ]
+ [ "Contents/Resources" append-path make-directories ]
+ [ "Contents/Resources" copy-theme ]
+ } cleave
]
[ create-app-plist ]
[ "Contents/MacOS/" append-path copy-vm ] 2tri
"specializer"
"step-into"
"step-into?"
+ ! UI needs this
+ ! "superclass"
"transform-n"
"transform-quot"
"tuple-dispatch-generic"
lexer-factory
print-use-hook
root-cache
- vocab-roots
vocabs:dictionary
vocabs:load-vocab-hook
word
: copy-dll ( bundle-name -- )
"resource:factor.dll" swap copy-file-into ;
-: copy-pango ( bundle-name -- )
- "resource:build-support/dlls.txt" ascii file-lines
- [ "resource:" prepend-path ] map
- swap copy-files-into ;
-
:: copy-vm ( executable bundle-name extension -- vm )
vm "." split1-last drop extension append
bundle-name executable ".exe" append append-path
: create-exe-dir ( vocab bundle-name -- vm )
dup copy-dll
deploy-ui? get [
- [ copy-pango ]
- [ "" copy-theme ]
- [ ".exe" copy-vm ] tri
+ [ "" copy-theme ] [ ".exe" copy-vm ] bi
] [ ".com" copy-vm ] if ;
M: winnt deploy*
! Copyright (C) 2005, 2006 Doug Coleman.
! Portions copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings arrays assocs ui
-ui.private ui.gadgets ui.gadgets.private ui.backend
-ui.clipboards ui.gadgets.worlds ui.gestures ui.event-loop io
-kernel math math.vectors namespaces make sequences strings
-vectors words windows.kernel32 windows.gdi32 windows.user32
-windows.opengl32 windows.messages windows.types windows.nt
-windows threads libc combinators fry combinators.short-circuit
-continuations command-line shuffle opengl ui.render ascii
-math.bitwise locals accessors math.rectangles math.order ascii
-calendar io.encodings.utf16n ;
+USING: alien alien.c-types alien.strings arrays assocs ui ui.private
+ui.gadgets ui.gadgets.private ui.backend ui.clipboards
+ui.gadgets.worlds ui.gestures ui.event-loop io kernel math
+math.vectors namespaces make sequences strings vectors words
+windows.kernel32 windows.gdi32 windows.user32 windows.opengl32
+windows.messages windows.types windows.offscreen windows.nt windows
+threads libc combinators fry combinators.short-circuit continuations
+command-line shuffle opengl ui.render ascii math.bitwise locals
+accessors math.rectangles math.order ascii calendar
+io.encodings.utf16n ;
IN: ui.backend.windows
SINGLETON: windows-ui-backend
style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
: make-RECT ( world -- RECT )
- [ window-loc>> dup ] [ dim>> ] bi v+
- "RECT" <c-object>
- over first over set-RECT-right
- swap second over set-RECT-bottom
- over first over set-RECT-left
- swap second over set-RECT-top ;
+ [ window-loc>> ] [ dim>> ] bi <RECT> ;
: default-position-RECT ( RECT -- )
dup get-RECT-dimensions [ 2drop ] 2dip
hWnd>> show-window ;
M: win-base select-gl-context ( handle -- )
- [ hDC>> ] keep hRC>> wglMakeCurrent win32-error=0/f
+ [ hDC>> ] [ hRC>> ] bi wglMakeCurrent win32-error=0/f
GdiFlush drop ;
M: win-base flush-gl-context ( handle -- )
hDC>> SwapBuffers win32-error=0/f ;
-: (bitmap-info) ( dim -- BITMAPINFO )
- "BITMAPINFO" <c-object> [
- BITMAPINFO-bmiHeader {
- [ nip "BITMAPINFOHEADER" heap-size swap set-BITMAPINFOHEADER-biSize ]
- [ [ first ] dip set-BITMAPINFOHEADER-biWidth ]
- [ [ second ] dip set-BITMAPINFOHEADER-biHeight ]
- [ nip 1 swap set-BITMAPINFOHEADER-biPlanes ]
- [ nip 32 swap set-BITMAPINFOHEADER-biBitCount ]
- [ nip BI_RGB swap set-BITMAPINFOHEADER-biCompression ]
- [ [ first2 * 4 * ] dip set-BITMAPINFOHEADER-biSizeImage ]
- [ nip 72 swap set-BITMAPINFOHEADER-biXPelsPerMeter ]
- [ nip 72 swap set-BITMAPINFOHEADER-biYPelsPerMeter ]
- [ nip 0 swap set-BITMAPINFOHEADER-biClrUsed ]
- [ nip 0 swap set-BITMAPINFOHEADER-biClrImportant ]
- } 2cleave
- ] keep ;
-
-: make-offscreen-dc-and-bitmap ( dim -- hDC hBitmap bits )
- f CreateCompatibleDC
- dup rot (bitmap-info) DIB_RGB_COLORS f <void*>
- [ f 0 CreateDIBSection ] keep *void*
- [ 2dup SelectObject drop ] dip ;
-
: setup-offscreen-gl ( dim -- hDC hRC hBitmap bits )
make-offscreen-dc-and-bitmap [
[ dup offscreen-pfd-dwFlags setup-pixel-format ]
! each pixel; it's left as zero
: (make-opaque) ( byte-array -- byte-array' )
- [ length 4 / ]
+ [ length 4 /i ]
[ '[ 255 swap 4 * 3 + _ set-nth ] each ]
[ ] tri ;
: (opaque-pixels) ( world -- pixels )
- [ handle>> bits>> ] [ dim>> first2 * 4 * ] bi
- memory>byte-array (make-opaque) ;
+ [ handle>> bits>> ] [ dim>> ] bi bitmap>byte-array (make-opaque) ;
M: windows-ui-backend offscreen-pixels ( world -- alien w h )
[ (opaque-pixels) ] [ dim>> first2 ] bi ;
: scroll>caret ( editor -- )
dup graft-state>> second [
[
- [ caret-loc ] [ caret-dim { 1 0 } v+ ] bi <rect>
+ [ caret-loc ] [ caret-dim { 2 1 } v+ ] bi <rect>
] keep scroll>rect
] [ drop ] if ;
CONSTANT: vertical { 0 1 }
TUPLE: gadget < rect
+id
pref-dim
parent
children
M: gadget equal? 2drop f ;
-M: gadget hashcode* drop gadget hashcode* ;
+M: gadget hashcode* nip [ [ \ gadget counter ] unless* ] change-id id>> ;
M: gadget model-changed 2drop ;
: validate-line ( m gadget -- n )
control-value [ drop f ] [ length 1- min 0 max ] if-empty ;
+: valid-line? ( n gadget -- ? )
+ control-value length 1- 0 swap between? ;
+
: visible-line ( gadget quot -- n )
'[
[ clip get @ origin get [ second ] bi@ - ] dip
: pane-caret&mark ( pane -- caret mark )
[ caret>> ] [ mark>> ] bi ; inline
-: selected-children ( pane -- seq )
+: selected-subtree ( pane -- seq )
[ pane-caret&mark sort-pair ] keep gadget-subtree ;
M: pane gadget-selection? pane-caret&mark and ;
M: pane gadget-selection ( pane -- string/f )
- selected-children gadget-text ;
+ selected-subtree gadget-text ;
: init-prototype ( pane -- pane )
<shelf> +baseline+ >>align >>prototype ; inline
[ >>last-line ] [ 1 track-add ] bi
dup prepare-last-line ; inline
-GENERIC: draw-selection ( loc obj -- )
-
-: if-fits ( rect quot -- )
- [ clip get over contains-rect? ] dip [ drop ] if ; inline
-
-M: gadget draw-selection ( loc gadget -- )
- swap offset-rect [
- rect-bounds gl-fill-rect
- ] if-fits ;
-
-M: node draw-selection ( loc node -- )
- 2dup value>> swap offset-rect [
- drop 2dup
- [ value>> loc>> v+ ] keep
- children>> [ draw-selection ] with each
- ] if-fits 2drop ;
-
-M: pane draw-gadget*
+M: pane selected-children
dup gadget-selection? [
- [ selection-color>> gl-color ]
- [
- [ loc>> vneg ] keep selected-children
- [ draw-selection ] with each
- ] bi
- ] [ drop ] if ;
+ [ selected-subtree leaves ]
+ [ selection-color>> ]
+ bi
+ ] [ drop f f ] if ;
: scroll-pane ( pane -- )
dup scrolls?>> [ scroll>bottom ] [ drop ] if ;
2dup control-value = [ 2drop ] [ set-control-value ] if ;
: (scroll>rect) ( rect scroller -- )
- [ [ loc>> ] [ dim>> { 1 1 } v+ ] bi <rect> ] dip
{
[ scroller-value vneg offset-rect ]
[ viewport>> dim>> rect-min ]
+ [ viewport>> loc>> offset-rect ]
[ viewport>> [ v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] with-rect-extents v+ ]
[ scroller-value v+ ]
[ scroll ]
: mouse-row ( table -- n )
[ hand-rel second ] keep y>line ;
+: if-mouse-row ( table true: ( table mouse-index -- ) false: ( table -- ) -- )
+ [ [ mouse-row ] keep 2dup valid-line? ]
+ [ ] [ '[ nip @ ] ] tri* if ; inline
+
: table-button-down ( table -- )
dup takes-focus?>> [ dup request-focus ] when
- dup control-value empty? [ drop ] [
- dup [ mouse-row ] keep validate-line
- [ >>mouse-index ] [ (select-row) ] bi
- ] if ;
+ [ swap [ >>mouse-index ] [ (select-row) ] bi ] [ drop ] if-mouse-row ;
PRIVATE>
[ 2drop ]
if ;
+: row-action? ( table -- ? )
+ [ [ mouse-row ] keep valid-line? ]
+ [ single-click?>> hand-click# get 2 = or ] bi and ;
+
<PRIVATE
: table-button-up ( table -- )
- dup single-click?>> hand-click# get 2 = or
- [ row-action ] [ update-selected-value ] if ;
+ dup row-action? [ row-action ] [ update-selected-value ] if ;
: select-row ( table n -- )
over validate-line
: next-page ( table -- )
1 prev/next-page ;
-: valid-row? ( row table -- ? )
- control-value length 1- 0 swap between? ;
-
-: if-mouse-row ( table true false -- )
- [ [ mouse-row ] keep 2dup valid-row? ]
- [ ] [ '[ nip @ ] ] tri* if ; inline
-
: show-mouse-help ( table -- )
[
swap
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
swap >>status
swap >>title
swap 1 track-add
- dup init-text-rendering
dup request-focus ;
: <world> ( gadget title status -- world )
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.
: rendered-image ( path -- texture )
world get image-texture-cache
- [ cached-image { 0 0 } <texture> ] cache ;
+ [ cached-image [ { 0 0 } ] keep dim>> <texture> ] cache ;
: draw-image ( image-name -- )
rendered-image draw-texture ;
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math.rectangles math.vectors namespaces kernel accessors
-combinators sequences opengl opengl.gl opengl.glu colors
+assocs combinators sequences opengl opengl.gl opengl.glu colors
colors.constants ui.gadgets ui.pens ;
IN: ui.render
GENERIC: draw-children ( gadget -- )
+! For gadget selection
+SYMBOL: selected-gadgets
+
+SYMBOL: selection-background
+
+GENERIC: selected-children ( gadget -- assoc/f selection-background )
+
+M: gadget selected-children drop f f ;
+
+! For text rendering
+SYMBOL: background
+
+SYMBOL: foreground
+
+GENERIC: gadget-background ( gadget -- color )
+
+M: gadget gadget-background dup interior>> pen-background ;
+
+GENERIC: gadget-foreground ( gadget -- color )
+
+M: gadget gadget-foreground dup interior>> pen-foreground ;
+
+<PRIVATE
+
+: draw-selection-background ( gadget -- )
+ selection-background get background set
+ selection-background get gl-color
+ [ { 0 0 } ] dip dim>> gl-fill-rect ;
+
+: draw-standard-background ( object -- )
+ dup interior>> dup [ draw-interior ] [ 2drop ] if ;
+
+: draw-background ( gadget -- )
+ origin get [
+ [
+ dup selected-gadgets get key?
+ [ draw-selection-background ]
+ [ draw-standard-background ] if
+ ] [ draw-gadget* ] bi
+ ] with-translation ;
+
+: draw-border ( object -- )
+ dup boundary>> dup [
+ origin get [ draw-boundary ] with-translation
+ ] [ 2drop ] if ;
+
+PRIVATE>
+
: (draw-gadget) ( gadget -- )
dup loc>> origin get v+ origin [
- [
- origin get [
- [ dup interior>> dup [ draw-interior ] [ 2drop ] if ]
- [ draw-gadget* ]
- bi
- ] with-translation
- ]
- [ draw-children ]
- [
- dup boundary>> dup [
- origin get [ draw-boundary ] with-translation
- ] [ 2drop ] if
- ] tri
+ [ draw-background ] [ draw-children ] [ draw-border ] tri
] with-variable ;
: >absolute ( rect -- rect )
[ [ (draw-gadget) ] with-clipping ]
} cond ;
-! For text rendering
-SYMBOL: background
-
-SYMBOL: foreground
-
-GENERIC: gadget-background ( gadget -- color )
-
-M: gadget gadget-background dup interior>> pen-background ;
-
-GENERIC: gadget-foreground ( gadget -- color )
-
-M: gadget gadget-foreground dup interior>> pen-foreground ;
-
M: gadget draw-children
- [ visible-children ]
- [ gadget-background ]
- [ gadget-foreground ] tri [
- [ foreground set ] when*
- [ background set ] when*
- [ draw-gadget ] each
- ] with-scope ;
+ dup children>> [
+ {
+ [ visible-children ]
+ [ selected-children ]
+ [ gadget-background ]
+ [ gadget-foreground ]
+ } cleave [
+
+ {
+ [ [ selected-gadgets set ] when* ]
+ [ [ selection-background set ] when* ]
+ [ [ background set ] when* ]
+ [ [ foreground set ] when* ]
+ } spread
+ [ draw-gadget ] each
+ ] with-scope
+ ] [ drop ] if ;
CONSTANT: selection-color T{ rgba f 0.8 0.8 1.0 1.0 }
SINGLETON: core-text-renderer
-M: core-text-renderer init-text-rendering
- <cache-assoc> >>text-handle drop ;
-
M: core-text-renderer string-dim
[ " " string-dim { 0 1 } v* ]
[ 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>>
- [ cached-line [ image>> ] [ loc>> ] bi <texture> ]
- 2cache ;
+ world get world-text-handle [
+ cached-line
+ [ image>> ] [ loc>> ] [ image>> dim>> ] tri
+ <texture>
+ ] 2cache ;
M: core-text-renderer draw-string ( font string -- )
rendered-line draw-texture ;
SINGLETON: pango-renderer
-M: pango-renderer init-text-rendering
- <cache-assoc> >>text-handle drop ;
-
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>>
- [ cached-layout [ image>> ] [ text-position vneg ] bi <texture> ]
- 2cache ;
+ world get world-text-handle [
+ cached-layout
+ [ image>> ] [ text-position vneg ] [ image>> dim>> ] tri
+ <texture>
+ ] 2cache ;
M: pango-renderer draw-string ( font string -- )
rendered-layout draw-texture ;
--- /dev/null
+UI text rendering implementation using cross-platform Pango library\r
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test ui.text fonts ;
+USING: tools.test ui.text fonts math accessors kernel sequences ;
IN: ui.text.tests
-[ 0.0 ] [ 0 sans-serif-font "aaa" offset>x ] unit-test
+[ t ] [ 0 sans-serif-font "aaa" offset>x zero? ] unit-test
+[ t ] [ 1 sans-serif-font "aaa" offset>x 0.0 > ] unit-test
+[ t ] [ 3 sans-serif-font "aaa" offset>x 0.0 > ] unit-test
+[ t ] [ 1 monospace-font "a" offset>x 0.0 > ] unit-test
+[ 0 ] [ 0 sans-serif-font "aaa" x>offset ] unit-test
+[ 3 ] [ 100 sans-serif-font "aaa" x>offset ] unit-test
+[ 0 ] [ 0 sans-serif-font "" x>offset ] unit-test
+
+[ t ] [
+ sans-serif-font "aaa" line-metrics
+ [ [ ascent>> ] [ descent>> ] bi + ] [ height>> ] bi =
+] unit-test
+
+[ f ] [ sans-serif-font "\0a" text-dim first zero? ] unit-test
+[ t ] [ sans-serif-font "" text-dim first zero? ] unit-test
+
+[ f ] [ sans-serif-font font-metrics height>> zero? ] unit-test
! 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 ;
+USING: kernel arrays sequences math math.order cache opengl
+opengl.gl strings fonts colors accessors namespaces
+ui.gadgets.worlds ;
IN: ui.text
<PRIVATE
SYMBOL: font-renderer
-HOOK: init-text-rendering font-renderer ( world -- )
+: world-text-handle ( world -- handle )
+ dup text-handle>> [ <cache-assoc> >>text-handle ] unless
+ text-handle>> ;
-HOOK: finish-text-rendering font-renderer ( world -- )
+HOOK: flush-layout-cache font-renderer ( -- )
-M: object finish-text-rendering drop ;
+[ flush-layout-cache ] flush-layout-cache-hook set-global
HOOK: string-dim font-renderer ( font string -- dim )
[ draw-string ]
[ [ 0.0 ] 2dip string-height 0.0 glTranslated ] 2bi
] with each
- ] do-matrix ;
\ No newline at end of file
+ ] do-matrix ;
+
+USING: vocabs.loader namespaces system combinators ;
+
+"ui-backend" get [
+ {
+ { [ os macosx? ] [ "core-text" ] }
+ { [ os windows? ] [ "uniscribe" ] }
+ { [ os unix? ] [ "pango" ] }
+ } cond
+] unless* "ui.text." prepend require
\ No newline at end of file
--- /dev/null
+Slava Pestov\r
--- /dev/null
+UI text rendering implementation using the MS Windows Uniscribe library\r
--- /dev/null
+unportable\r
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors assocs cache kernel math math.vectors sequences fonts\r
+namespaces opengl.textures ui.text ui.text.private ui.gadgets.worlds \r
+windows.uniscribe ;\r
+IN: ui.text.uniscribe\r
+\r
+SINGLETON: uniscribe-renderer\r
+\r
+M: uniscribe-renderer string-dim\r
+ [ " " string-dim { 0 1 } v* ]\r
+ [ cached-script-string size>> ] if-empty ;\r
+\r
+M: uniscribe-renderer flush-layout-cache\r
+ cached-script-strings get purge-cache ;\r
+\r
+: rendered-script-string ( font string -- texture )\r
+ world get world-text-handle\r
+ [ cached-script-string [ image>> { 0 0 } ] [ size>> ] bi <texture> ]\r
+ 2cache ;\r
+\r
+M: uniscribe-renderer draw-string ( font string -- )\r
+ dup dup selection? [ string>> ] when empty?\r
+ [ 2drop ] [ rendered-script-string draw-texture ] if ;\r
+\r
+M: uniscribe-renderer x>offset ( x font string -- n )\r
+ [ 2drop 0 ] [\r
+ cached-script-string x>line-offset 0 = [ 1+ ] unless\r
+ ] if-empty ;\r
+\r
+M: uniscribe-renderer offset>x ( n font string -- x )\r
+ [ 2drop 0 ] [ cached-script-string line-offset>x ] if-empty ;\r
+\r
+M: uniscribe-renderer font-metrics ( font -- metrics )\r
+ " " cached-script-string metrics>> clone f >>width ;\r
+\r
+M: uniscribe-renderer line-metrics ( font string -- metrics )\r
+ [ " " line-metrics clone 0 >>width ]\r
+ [ cached-script-string metrics>> 50 >>width 10 >>cap-height 10 >>x-height ]\r
+ if-empty ;\r
+\r
+uniscribe-renderer font-renderer set-global\r
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" }
t >>selection-required?
t >>single-click?
30 >>min-cols
+ 10 >>min-rows
10 >>max-rows
dup '[ _ accept-completion ] >>action ;
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors namespaces make sequences kernel math arrays io
-ui.gadgets generic combinators ;
+ui.gadgets generic combinators fry sets ;
IN: ui.traverse
TUPLE: node value children ;
: gadget-at-path ( parent path -- gadget )
[ swap nth-gadget ] each ;
+
+GENERIC# leaves* 1 ( tree assoc -- )
+
+M: node leaves* [ children>> ] dip leaves* ;
+
+M: array leaves* '[ _ leaves* ] each ;
+
+M: gadget leaves* conjoin ;
+
+: leaves ( tree -- assoc ) H{ } clone [ leaves* ] keep ;
\ No newline at end of file
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
: (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 ]
: restore-world ( world -- )
{
[ reset-world ]
- [ init-text-rendering ]
- [ f >>images drop ]
+ [ f >>text-handle f >>images drop ]
[ restore-gadget ]
} cleave ;
[ 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" ;
[ 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 )
: 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
[ "Lo" ] [ HEX: 3450 category ] unit-test
[ "Lo" ] [ HEX: 4DB5 category ] unit-test
[ "Cs" ] [ HEX: DD00 category ] unit-test
+[ t ] [ CHAR: \t blank? ] unit-test
+[ t ] [ CHAR: \s blank? ] unit-test
+[ t ] [ CHAR: \r blank? ] unit-test
+[ t ] [ CHAR: \n blank? ] unit-test
+[ f ] [ CHAR: a blank? ] unit-test
USING: unicode.categories.syntax sequences unicode.data ;
IN: unicode.categories
-CATEGORY: blank Zs Zl Zp | "\r\n" member? ;
+CATEGORY: blank Zs Zl Zp | "\r\n\t" member? ;
CATEGORY: letter Ll | "Other_Lowercase" property? ;
CATEGORY: LETTER Lu | "Other_Uppercase" property? ;
CATEGORY: Letter Lu Ll Lt Lm Lo Nl ;
} ;
HELP: ensure-port
-{ $values { "url" url } }
-{ $description "If the URL does not specify a port number, fill in the default for the URL's protocol. If the protocol is unknown, the port number is not changed." }
-{ $side-effects "url" }
+{ $values { "url" url } { "url'" url } }
+{ $description "If the URL does not specify a port number, create a new URL which is equal except the port number is set to the default for the URL's protocol. If the protocol is unknown, outputs an exact copy of the input URL." }
{ $examples
{ $example
"USING: accessors prettyprint urls ;"
] [ protocol>> ] bi
secure-protocol? [ >secure-addr ] when ;
-: ensure-port ( url -- url )
- dup protocol>> '[ _ protocol-port or ] change-port ;
+: ensure-port ( url -- url' )
+ clone dup protocol>> '[ _ protocol-port or ] change-port ;
! Literal syntax
SYNTAX: URL" lexer get skip-blank parse-string >url parsed ;
--- /dev/null
+USING: assocs memoize locals kernel accessors init fonts math\r
+combinators windows windows.types windows.gdi32 ;\r
+IN: windows.fonts\r
+\r
+: windows-font-name ( string -- string' )\r
+ H{\r
+ { "sans-serif" "Tahoma" }\r
+ { "serif" "Times New Roman" }\r
+ { "monospace" "Courier New" }\r
+ } at-default ;\r
+ \r
+MEMO:: (cache-font) ( font -- HFONT )\r
+ font size>> neg ! nHeight\r
+ 0 0 0 ! nWidth, nEscapement, nOrientation\r
+ font bold?>> FW_BOLD FW_NORMAL ? ! fnWeight\r
+ font italic?>> TRUE FALSE ? ! fdwItalic\r
+ FALSE ! fdwUnderline\r
+ FALSE ! fdWStrikeOut\r
+ DEFAULT_CHARSET ! fdwCharSet\r
+ OUT_OUTLINE_PRECIS ! fdwOutputPrecision\r
+ CLIP_DEFAULT_PRECIS ! fdwClipPrecision\r
+ DEFAULT_QUALITY ! fdwQuality\r
+ DEFAULT_PITCH ! fdwPitchAndFamily\r
+ font name>> windows-font-name\r
+ CreateFont\r
+ dup win32-error=0/f ;\r
+\r
+: cache-font ( font -- HFONT ) strip-font-colors (cache-font) ;\r
+\r
+[ \ (cache-font) reset-memoized ] "windows.fonts" add-init-hook\r
+\r
+: TEXTMETRIC>metrics ( TEXTMETRIC -- metrics )\r
+ [ metrics new 0 >>width ] dip {\r
+ [ TEXTMETRICW-tmHeight >>height ]\r
+ [ TEXTMETRICW-tmAscent >>ascent ]\r
+ [ TEXTMETRICW-tmDescent >>descent ]\r
+ } cleave ;\r
-! FUNCTION: AbortDoc
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax kernel windows.types ;
+USING: alien alien.syntax alien.destructors kernel windows.types
+math.bitwise ;
IN: windows.gdi32
-! Stock Logical Objects
-CONSTANT: WHITE_BRUSH 0
-CONSTANT: LTGRAY_BRUSH 1
-CONSTANT: GRAY_BRUSH 2
-CONSTANT: DKGRAY_BRUSH 3
-CONSTANT: BLACK_BRUSH 4
-CONSTANT: NULL_BRUSH 5
-ALIAS: HOLLOW_BRUSH NULL_BRUSH
-CONSTANT: WHITE_PEN 6
-CONSTANT: BLACK_PEN 7
-CONSTANT: NULL_PEN 8
-CONSTANT: OEM_FIXED_FONT 10
-CONSTANT: ANSI_FIXED_FONT 11
-CONSTANT: ANSI_VAR_FONT 12
-CONSTANT: SYSTEM_FONT 13
+CONSTANT: BI_RGB 0
+CONSTANT: BI_RLE8 1
+CONSTANT: BI_RLE4 2
+CONSTANT: BI_BITFIELDS 3
+CONSTANT: BI_JPEG 4
+CONSTANT: BI_PNG 5
+CONSTANT: LF_FACESIZE 32
+CONSTANT: LF_FULLFACESIZE 64
+CONSTANT: CA_NEGATIVE 1
+CONSTANT: CA_LOG_FILTER 2
+CONSTANT: ILLUMINANT_DEVICE_DEFAULT 0
+CONSTANT: ILLUMINANT_A 1
+CONSTANT: ILLUMINANT_B 2
+CONSTANT: ILLUMINANT_C 3
+CONSTANT: ILLUMINANT_D50 4
+CONSTANT: ILLUMINANT_D55 5
+CONSTANT: ILLUMINANT_D65 6
+CONSTANT: ILLUMINANT_D75 7
+CONSTANT: ILLUMINANT_F2 8
+ALIAS: ILLUMINANT_MAX_INDEX ILLUMINANT_F2
+ALIAS: ILLUMINANT_TUNGSTEN ILLUMINANT_A
+ALIAS: ILLUMINANT_DAYLIGHT ILLUMINANT_C
+ALIAS: ILLUMINANT_FLUORESCENT ILLUMINANT_F2
+ALIAS: ILLUMINANT_NTSC ILLUMINANT_C
+CONSTANT: RGB_GAMMA_MIN 2500
+CONSTANT: RGB_GAMMA_MAX 65000
+CONSTANT: REFERENCE_WHITE_MIN 6000
+CONSTANT: REFERENCE_WHITE_MAX 10000
+CONSTANT: REFERENCE_BLACK_MIN 0
+CONSTANT: REFERENCE_BLACK_MAX 4000
+CONSTANT: COLOR_ADJ_MIN -100
+CONSTANT: COLOR_ADJ_MAX 100
+CONSTANT: CCHDEVICENAME 32
+CONSTANT: CCHFORMNAME 32
+CONSTANT: DI_COMPAT 4
+CONSTANT: DI_DEFAULTSIZE 8
+CONSTANT: DI_IMAGE 2
+CONSTANT: DI_MASK 1
+CONSTANT: DI_NORMAL 3
+CONSTANT: DI_APPBANDING 1
+CONSTANT: EMR_HEADER 1
+CONSTANT: EMR_POLYBEZIER 2
+CONSTANT: EMR_POLYGON 3
+CONSTANT: EMR_POLYLINE 4
+CONSTANT: EMR_POLYBEZIERTO 5
+CONSTANT: EMR_POLYLINETO 6
+CONSTANT: EMR_POLYPOLYLINE 7
+CONSTANT: EMR_POLYPOLYGON 8
+CONSTANT: EMR_SETWINDOWEXTEX 9
+CONSTANT: EMR_SETWINDOWORGEX 10
+CONSTANT: EMR_SETVIEWPORTEXTEX 11
+CONSTANT: EMR_SETVIEWPORTORGEX 12
+CONSTANT: EMR_SETBRUSHORGEX 13
+CONSTANT: EMR_EOF 14
+CONSTANT: EMR_SETPIXELV 15
+CONSTANT: EMR_SETMAPPERFLAGS 16
+CONSTANT: EMR_SETMAPMODE 17
+CONSTANT: EMR_SETBKMODE 18
+CONSTANT: EMR_SETPOLYFILLMODE 19
+CONSTANT: EMR_SETROP2 20
+CONSTANT: EMR_SETSTRETCHBLTMODE 21
+CONSTANT: EMR_SETTEXTALIGN 22
+CONSTANT: EMR_SETCOLORADJUSTMENT 23
+CONSTANT: EMR_SETTEXTCOLOR 24
+CONSTANT: EMR_SETBKCOLOR 25
+CONSTANT: EMR_OFFSETCLIPRGN 26
+CONSTANT: EMR_MOVETOEX 27
+CONSTANT: EMR_SETMETARGN 28
+CONSTANT: EMR_EXCLUDECLIPRECT 29
+CONSTANT: EMR_INTERSECTCLIPRECT 30
+CONSTANT: EMR_SCALEVIEWPORTEXTEX 31
+CONSTANT: EMR_SCALEWINDOWEXTEX 32
+CONSTANT: EMR_SAVEDC 33
+CONSTANT: EMR_RESTOREDC 34
+CONSTANT: EMR_SETWORLDTRANSFORM 35
+CONSTANT: EMR_MODIFYWORLDTRANSFORM 36
+CONSTANT: EMR_SELECTOBJECT 37
+CONSTANT: EMR_CREATEPEN 38
+CONSTANT: EMR_CREATEBRUSHINDIRECT 39
+CONSTANT: EMR_DELETEOBJECT 40
+CONSTANT: EMR_ANGLEARC 41
+CONSTANT: EMR_ELLIPSE 42
+CONSTANT: EMR_RECTANGLE 43
+CONSTANT: EMR_ROUNDRECT 44
+CONSTANT: EMR_ARC 45
+CONSTANT: EMR_CHORD 46
+CONSTANT: EMR_PIE 47
+CONSTANT: EMR_SELECTPALETTE 48
+CONSTANT: EMR_CREATEPALETTE 49
+CONSTANT: EMR_SETPALETTEENTRIES 50
+CONSTANT: EMR_RESIZEPALETTE 51
+CONSTANT: EMR_REALIZEPALETTE 52
+CONSTANT: EMR_EXTFLOODFILL 53
+CONSTANT: EMR_LINETO 54
+CONSTANT: EMR_ARCTO 55
+CONSTANT: EMR_POLYDRAW 56
+CONSTANT: EMR_SETARCDIRECTION 57
+CONSTANT: EMR_SETMITERLIMIT 58
+CONSTANT: EMR_BEGINPATH 59
+CONSTANT: EMR_ENDPATH 60
+CONSTANT: EMR_CLOSEFIGURE 61
+CONSTANT: EMR_FILLPATH 62
+CONSTANT: EMR_STROKEANDFILLPATH 63
+CONSTANT: EMR_STROKEPATH 64
+CONSTANT: EMR_FLATTENPATH 65
+CONSTANT: EMR_WIDENPATH 66
+CONSTANT: EMR_SELECTCLIPPATH 67
+CONSTANT: EMR_ABORTPATH 68
+CONSTANT: EMR_GDICOMMENT 70
+CONSTANT: EMR_FILLRGN 71
+CONSTANT: EMR_FRAMERGN 72
+CONSTANT: EMR_INVERTRGN 73
+CONSTANT: EMR_PAINTRGN 74
+CONSTANT: EMR_EXTSELECTCLIPRGN 75
+CONSTANT: EMR_BITBLT 76
+CONSTANT: EMR_STRETCHBLT 77
+CONSTANT: EMR_MASKBLT 78
+CONSTANT: EMR_PLGBLT 79
+CONSTANT: EMR_SETDIBITSTODEVICE 80
+CONSTANT: EMR_STRETCHDIBITS 81
+CONSTANT: EMR_EXTCREATEFONTINDIRECTW 82
+CONSTANT: EMR_EXTTEXTOUTA 83
+CONSTANT: EMR_EXTTEXTOUTW 84
+CONSTANT: EMR_POLYBEZIER16 85
+CONSTANT: EMR_POLYGON16 86
+CONSTANT: EMR_POLYLINE16 87
+CONSTANT: EMR_POLYBEZIERTO16 88
+CONSTANT: EMR_POLYLINETO16 89
+CONSTANT: EMR_POLYPOLYLINE16 90
+CONSTANT: EMR_POLYPOLYGON16 91
+CONSTANT: EMR_POLYDRAW16 92
+CONSTANT: EMR_CREATEMONOBRUSH 93
+CONSTANT: EMR_CREATEDIBPATTERNBRUSHPT 94
+CONSTANT: EMR_EXTCREATEPEN 95
+CONSTANT: EMR_POLYTEXTOUTA 96
+CONSTANT: EMR_POLYTEXTOUTW 97
+CONSTANT: EMR_SETICMMODE 98
+CONSTANT: EMR_CREATECOLORSPACE 99
+CONSTANT: EMR_SETCOLORSPACE 100
+CONSTANT: EMR_DELETECOLORSPACE 101
+CONSTANT: EMR_GLSRECORD 102
+CONSTANT: EMR_GLSBOUNDEDRECORD 103
+CONSTANT: EMR_PIXELFORMAT 104
+CONSTANT: ENHMETA_SIGNATURE 1179469088
+CONSTANT: EPS_SIGNATURE HEX: 46535045
+CONSTANT: FR_PRIVATE HEX: 10
+CONSTANT: FR_NOT_ENUM HEX: 20
+CONSTANT: META_SETBKCOLOR HEX: 201
+CONSTANT: META_SETBKMODE HEX: 102
+CONSTANT: META_SETMAPMODE HEX: 103
+CONSTANT: META_SETROP2 HEX: 104
+CONSTANT: META_SETRELABS HEX: 105
+CONSTANT: META_SETPOLYFILLMODE HEX: 106
+CONSTANT: META_SETSTRETCHBLTMODE HEX: 107
+CONSTANT: META_SETTEXTCHAREXTRA HEX: 108
+CONSTANT: META_SETTEXTCOLOR HEX: 209
+CONSTANT: META_SETTEXTJUSTIFICATION HEX: 20A
+CONSTANT: META_SETWINDOWORG HEX: 20B
+CONSTANT: META_SETWINDOWEXT HEX: 20C
+CONSTANT: META_SETVIEWPORTORG HEX: 20D
+CONSTANT: META_SETVIEWPORTEXT HEX: 20E
+CONSTANT: META_OFFSETWINDOWORG HEX: 20F
+CONSTANT: META_SCALEWINDOWEXT HEX: 410
+CONSTANT: META_OFFSETVIEWPORTORG HEX: 211
+CONSTANT: META_SCALEVIEWPORTEXT HEX: 412
+CONSTANT: META_LINETO HEX: 213
+CONSTANT: META_MOVETO HEX: 214
+CONSTANT: META_EXCLUDECLIPRECT HEX: 415
+CONSTANT: META_INTERSECTCLIPRECT HEX: 416
+CONSTANT: META_ARC HEX: 817
+CONSTANT: META_ELLIPSE HEX: 418
+CONSTANT: META_FLOODFILL HEX: 419
+CONSTANT: META_PIE HEX: 81A
+CONSTANT: META_RECTANGLE HEX: 41B
+CONSTANT: META_ROUNDRECT HEX: 61C
+CONSTANT: META_PATBLT HEX: 61D
+CONSTANT: META_SAVEDC HEX: 1E
+CONSTANT: META_SETPIXEL HEX: 41F
+CONSTANT: META_OFFSETCLIPRGN HEX: 220
+CONSTANT: META_TEXTOUT HEX: 521
+CONSTANT: META_BITBLT HEX: 922
+CONSTANT: META_STRETCHBLT HEX: b23
+CONSTANT: META_POLYGON HEX: 324
+CONSTANT: META_POLYLINE HEX: 325
+CONSTANT: META_ESCAPE HEX: 626
+CONSTANT: META_RESTOREDC HEX: 127
+CONSTANT: META_FILLREGION HEX: 228
+CONSTANT: META_FRAMEREGION HEX: 429
+CONSTANT: META_INVERTREGION HEX: 12A
+CONSTANT: META_PAINTREGION HEX: 12B
+CONSTANT: META_SELECTCLIPREGION HEX: 12C
+CONSTANT: META_SELECTOBJECT HEX: 12D
+CONSTANT: META_SETTEXTALIGN HEX: 12E
+CONSTANT: META_CHORD HEX: 830
+CONSTANT: META_SETMAPPERFLAGS HEX: 231
+CONSTANT: META_EXTTEXTOUT HEX: a32
+CONSTANT: META_SETDIBTODEV HEX: d33
+CONSTANT: META_SELECTPALETTE HEX: 234
+CONSTANT: META_REALIZEPALETTE HEX: 35
+CONSTANT: META_ANIMATEPALETTE HEX: 436
+CONSTANT: META_SETPALENTRIES HEX: 37
+CONSTANT: META_POLYPOLYGON HEX: 538
+CONSTANT: META_RESIZEPALETTE HEX: 139
+CONSTANT: META_DIBBITBLT HEX: 940
+CONSTANT: META_DIBSTRETCHBLT HEX: b41
+CONSTANT: META_DIBCREATEPATTERNBRUSH HEX: 142
+CONSTANT: META_STRETCHDIB HEX: f43
+CONSTANT: META_EXTFLOODFILL HEX: 548
+CONSTANT: META_DELETEOBJECT HEX: 1f0
+CONSTANT: META_CREATEPALETTE HEX: f7
+CONSTANT: META_CREATEPATTERNBRUSH HEX: 1F9
+CONSTANT: META_CREATEPENINDIRECT HEX: 2FA
+CONSTANT: META_CREATEFONTINDIRECT HEX: 2FB
+CONSTANT: META_CREATEBRUSHINDIRECT HEX: 2FC
+CONSTANT: META_CREATEREGION HEX: 6FF
+CONSTANT: ELF_VENDOR_SIZE 4
+CONSTANT: ELF_VERSION 0
+CONSTANT: ELF_CULTURE_LATIN 0
+CONSTANT: PFD_TYPE_RGBA 0
+CONSTANT: PFD_TYPE_COLORINDEX 1
+CONSTANT: PFD_MAIN_PLANE 0
+CONSTANT: PFD_OVERLAY_PLANE 1
+CONSTANT: PFD_UNDERLAY_PLANE -1
+CONSTANT: PFD_DOUBLEBUFFER 1
+CONSTANT: PFD_STEREO 2
+CONSTANT: PFD_DRAW_TO_WINDOW 4
+CONSTANT: PFD_DRAW_TO_BITMAP 8
+CONSTANT: PFD_SUPPORT_GDI 16
+CONSTANT: PFD_SUPPORT_OPENGL 32
+CONSTANT: PFD_GENERIC_FORMAT 64
+CONSTANT: PFD_NEED_PALETTE 128
+CONSTANT: PFD_NEED_SYSTEM_PALETTE HEX: 00000100
+CONSTANT: PFD_SWAP_EXCHANGE HEX: 00000200
+CONSTANT: PFD_SWAP_COPY HEX: 00000400
+CONSTANT: PFD_SWAP_LAYER_BUFFERS HEX: 00000800
+CONSTANT: PFD_GENERIC_ACCELERATED HEX: 00001000
+CONSTANT: PFD_DEPTH_DONTCARE HEX: 20000000
+CONSTANT: PFD_DOUBLEBUFFER_DONTCARE HEX: 40000000
+CONSTANT: PFD_STEREO_DONTCARE HEX: 80000000
+CONSTANT: SP_ERROR -1
+CONSTANT: SP_OUTOFDISK -4
+CONSTANT: SP_OUTOFMEMORY -5
+CONSTANT: SP_USERABORT -3
+CONSTANT: SP_APPABORT -2
+CONSTANT: BLACKNESS HEX: 00000042
+CONSTANT: NOTSRCERASE HEX: 001100A6
+CONSTANT: NOTSRCCOPY HEX: 00330008
+CONSTANT: SRCERASE HEX: 00440328
+CONSTANT: DSTINVERT HEX: 00550009
+CONSTANT: PATINVERT HEX: 005A0049
+CONSTANT: SRCINVERT HEX: 00660046
+CONSTANT: SRCAND HEX: 008800C6
+CONSTANT: MERGEPAINT HEX: 00BB0226
+CONSTANT: MERGECOPY HEX: 00C000CA
+CONSTANT: SRCCOPY HEX: 00CC0020
+CONSTANT: SRCPAINT HEX: 00EE0086
+CONSTANT: PATCOPY HEX: 00F00021
+CONSTANT: PATPAINT HEX: 00FB0A09
+CONSTANT: WHITENESS HEX: 00FF0062
+CONSTANT: CAPTUREBLT HEX: 40000000
+CONSTANT: NOMIRRORBITMAP HEX: 80000000
+CONSTANT: R2_BLACK 1
+CONSTANT: R2_COPYPEN 13
+CONSTANT: R2_MASKNOTPEN 3
+CONSTANT: R2_MASKPEN 9
+CONSTANT: R2_MASKPENNOT 5
+CONSTANT: R2_MERGENOTPEN 12
+CONSTANT: R2_MERGEPEN 15
+CONSTANT: R2_MERGEPENNOT 14
+CONSTANT: R2_NOP 11
+CONSTANT: R2_NOT 6
+CONSTANT: R2_NOTCOPYPEN 4
+CONSTANT: R2_NOTMASKPEN 8
+CONSTANT: R2_NOTMERGEPEN 2
+CONSTANT: R2_NOTXORPEN 10
+CONSTANT: R2_WHITE 16
+CONSTANT: R2_XORPEN 7
+CONSTANT: CM_OUT_OF_GAMUT 255
+CONSTANT: CM_IN_GAMUT 0
+CONSTANT: RGN_AND 1
+CONSTANT: RGN_COPY 5
+CONSTANT: RGN_DIFF 4
+CONSTANT: RGN_OR 2
+CONSTANT: RGN_XOR 3
+CONSTANT: NULLREGION 1
+CONSTANT: SIMPLEREGION 2
+CONSTANT: COMPLEXREGION 3
+CONSTANT: ERROR 0
+CONSTANT: CBM_INIT 4
+CONSTANT: DIB_PAL_COLORS 1
+CONSTANT: DIB_RGB_COLORS 0
+CONSTANT: FW_DONTCARE 0
+CONSTANT: FW_THIN 100
+CONSTANT: FW_EXTRALIGHT 200
+ALIAS: FW_ULTRALIGHT FW_EXTRALIGHT
+CONSTANT: FW_LIGHT 300
+CONSTANT: FW_NORMAL 400
+CONSTANT: FW_REGULAR 400
+CONSTANT: FW_MEDIUM 500
+CONSTANT: FW_SEMIBOLD 600
+ALIAS: FW_DEMIBOLD FW_SEMIBOLD
+CONSTANT: FW_BOLD 700
+CONSTANT: FW_EXTRABOLD 800
+ALIAS: FW_ULTRABOLD FW_EXTRABOLD
+CONSTANT: FW_HEAVY 900
+ALIAS: FW_BLACK FW_HEAVY
+CONSTANT: ANSI_CHARSET 0
+CONSTANT: DEFAULT_CHARSET 1
+CONSTANT: SYMBOL_CHARSET 2
+CONSTANT: SHIFTJIS_CHARSET 128
+CONSTANT: HANGEUL_CHARSET 129
+CONSTANT: HANGUL_CHARSET 129
+CONSTANT: GB2312_CHARSET 134
+CONSTANT: CHINESEBIG5_CHARSET 136
+CONSTANT: GREEK_CHARSET 161
+CONSTANT: TURKISH_CHARSET 162
+CONSTANT: HEBREW_CHARSET 177
+CONSTANT: ARABIC_CHARSET 178
+CONSTANT: BALTIC_CHARSET 186
+CONSTANT: RUSSIAN_CHARSET 204
+CONSTANT: THAI_CHARSET 222
+CONSTANT: EASTEUROPE_CHARSET 238
+CONSTANT: OEM_CHARSET 255
+CONSTANT: JOHAB_CHARSET 130
+CONSTANT: VIETNAMESE_CHARSET 163
+CONSTANT: MAC_CHARSET 77
+CONSTANT: OUT_DEFAULT_PRECIS 0
+CONSTANT: OUT_STRING_PRECIS 1
+CONSTANT: OUT_CHARACTER_PRECIS 2
+CONSTANT: OUT_STROKE_PRECIS 3
+CONSTANT: OUT_TT_PRECIS 4
+CONSTANT: OUT_DEVICE_PRECIS 5
+CONSTANT: OUT_RASTER_PRECIS 6
+CONSTANT: OUT_TT_ONLY_PRECIS 7
+CONSTANT: OUT_OUTLINE_PRECIS 8
+CONSTANT: CLIP_DEFAULT_PRECIS 0
+CONSTANT: CLIP_CHARACTER_PRECIS 1
+CONSTANT: CLIP_STROKE_PRECIS 2
+CONSTANT: CLIP_MASK 15
+CONSTANT: CLIP_LH_ANGLES 16
+CONSTANT: CLIP_TT_ALWAYS 32
+CONSTANT: CLIP_EMBEDDED 128
+CONSTANT: DEFAULT_QUALITY 0
+CONSTANT: DRAFT_QUALITY 1
+CONSTANT: PROOF_QUALITY 2
+CONSTANT: NONANTIALIASED_QUALITY 3
+CONSTANT: ANTIALIASED_QUALITY 4
+CONSTANT: DEFAULT_PITCH 0
+CONSTANT: FIXED_PITCH 1
+CONSTANT: VARIABLE_PITCH 2
+CONSTANT: MONO_FONT 8
+CONSTANT: FF_DECORATIVE 80
+CONSTANT: FF_DONTCARE 0
+CONSTANT: FF_MODERN 48
+CONSTANT: FF_ROMAN 16
+CONSTANT: FF_SCRIPT 64
+CONSTANT: FF_SWISS 32
+CONSTANT: PANOSE_COUNT 10
+CONSTANT: PAN_FAMILYTYPE_INDEX 0
+CONSTANT: PAN_SERIFSTYLE_INDEX 1
+CONSTANT: PAN_WEIGHT_INDEX 2
+CONSTANT: PAN_PROPORTION_INDEX 3
+CONSTANT: PAN_CONTRAST_INDEX 4
+CONSTANT: PAN_STROKEVARIATION_INDEX 5
+CONSTANT: PAN_ARMSTYLE_INDEX 6
+CONSTANT: PAN_LETTERFORM_INDEX 7
+CONSTANT: PAN_MIDLINE_INDEX 8
+CONSTANT: PAN_XHEIGHT_INDEX 9
+CONSTANT: PAN_CULTURE_LATIN 0
+CONSTANT: PAN_ANY 0
+CONSTANT: PAN_NO_FIT 1
+CONSTANT: PAN_FAMILY_TEXT_DISPLAY 2
+CONSTANT: PAN_FAMILY_SCRIPT 3
+CONSTANT: PAN_FAMILY_DECORATIVE 4
+CONSTANT: PAN_FAMILY_PICTORIAL 5
+CONSTANT: PAN_SERIF_COVE 2
+CONSTANT: PAN_SERIF_OBTUSE_COVE 3
+CONSTANT: PAN_SERIF_SQUARE_COVE 4
+CONSTANT: PAN_SERIF_OBTUSE_SQUARE_COVE 5
+CONSTANT: PAN_SERIF_SQUARE 6
+CONSTANT: PAN_SERIF_THIN 7
+CONSTANT: PAN_SERIF_BONE 8
+CONSTANT: PAN_SERIF_EXAGGERATED 9
+CONSTANT: PAN_SERIF_TRIANGLE 10
+CONSTANT: PAN_SERIF_NORMAL_SANS 11
+CONSTANT: PAN_SERIF_OBTUSE_SANS 12
+CONSTANT: PAN_SERIF_PERP_SANS 13
+CONSTANT: PAN_SERIF_FLARED 14
+CONSTANT: PAN_SERIF_ROUNDED 15
+CONSTANT: PAN_WEIGHT_VERY_LIGHT 2
+CONSTANT: PAN_WEIGHT_LIGHT 3
+CONSTANT: PAN_WEIGHT_THIN 4
+CONSTANT: PAN_WEIGHT_BOOK 5
+CONSTANT: PAN_WEIGHT_MEDIUM 6
+CONSTANT: PAN_WEIGHT_DEMI 7
+CONSTANT: PAN_WEIGHT_BOLD 8
+CONSTANT: PAN_WEIGHT_HEAVY 9
+CONSTANT: PAN_WEIGHT_BLACK 10
+CONSTANT: PAN_WEIGHT_NORD 11
+CONSTANT: PAN_PROP_OLD_STYLE 2
+CONSTANT: PAN_PROP_MODERN 3
+CONSTANT: PAN_PROP_EVEN_WIDTH 4
+CONSTANT: PAN_PROP_EXPANDED 5
+CONSTANT: PAN_PROP_CONDENSED 6
+CONSTANT: PAN_PROP_VERY_EXPANDED 7
+CONSTANT: PAN_PROP_VERY_CONDENSED 8
+CONSTANT: PAN_PROP_MONOSPACED 9
+CONSTANT: PAN_CONTRAST_NONE 2
+CONSTANT: PAN_CONTRAST_VERY_LOW 3
+CONSTANT: PAN_CONTRAST_LOW 4
+CONSTANT: PAN_CONTRAST_MEDIUM_LOW 5
+CONSTANT: PAN_CONTRAST_MEDIUM 6
+CONSTANT: PAN_CONTRAST_MEDIUM_HIGH 7
+CONSTANT: PAN_CONTRAST_HIGH 8
+CONSTANT: PAN_CONTRAST_VERY_HIGH 9
+CONSTANT: PAN_STROKE_GRADUAL_DIAG 2
+CONSTANT: PAN_STROKE_GRADUAL_TRAN 3
+CONSTANT: PAN_STROKE_GRADUAL_VERT 4
+CONSTANT: PAN_STROKE_GRADUAL_HORZ 5
+CONSTANT: PAN_STROKE_RAPID_VERT 6
+CONSTANT: PAN_STROKE_RAPID_HORZ 7
+CONSTANT: PAN_STROKE_INSTANT_VERT 8
+CONSTANT: PAN_STRAIGHT_ARMS_HORZ 2
+CONSTANT: PAN_STRAIGHT_ARMS_WEDGE 3
+CONSTANT: PAN_STRAIGHT_ARMS_VERT 4
+CONSTANT: PAN_STRAIGHT_ARMS_SINGLE_SERIF 5
+CONSTANT: PAN_STRAIGHT_ARMS_DOUBLE_SERIF 6
+CONSTANT: PAN_BENT_ARMS_HORZ 7
+CONSTANT: PAN_BENT_ARMS_WEDGE 8
+CONSTANT: PAN_BENT_ARMS_VERT 9
+CONSTANT: PAN_BENT_ARMS_SINGLE_SERIF 10
+CONSTANT: PAN_BENT_ARMS_DOUBLE_SERIF 11
+CONSTANT: PAN_LETT_NORMAL_CONTACT 2
+CONSTANT: PAN_LETT_NORMAL_WEIGHTED 3
+CONSTANT: PAN_LETT_NORMAL_BOXED 4
+CONSTANT: PAN_LETT_NORMAL_FLATTENED 5
+CONSTANT: PAN_LETT_NORMAL_ROUNDED 6
+CONSTANT: PAN_LETT_NORMAL_OFF_CENTER 7
+CONSTANT: PAN_LETT_NORMAL_SQUARE 8
+CONSTANT: PAN_LETT_OBLIQUE_CONTACT 9
+CONSTANT: PAN_LETT_OBLIQUE_WEIGHTED 10
+CONSTANT: PAN_LETT_OBLIQUE_BOXED 11
+CONSTANT: PAN_LETT_OBLIQUE_FLATTENED 12
+CONSTANT: PAN_LETT_OBLIQUE_ROUNDED 13
+CONSTANT: PAN_LETT_OBLIQUE_OFF_CENTER 14
+CONSTANT: PAN_LETT_OBLIQUE_SQUARE 15
+CONSTANT: PAN_MIDLINE_STANDARD_TRIMMED 2
+CONSTANT: PAN_MIDLINE_STANDARD_POINTED 3
+CONSTANT: PAN_MIDLINE_STANDARD_SERIFED 4
+CONSTANT: PAN_MIDLINE_HIGH_TRIMMED 5
+CONSTANT: PAN_MIDLINE_HIGH_POINTED 6
+CONSTANT: PAN_MIDLINE_HIGH_SERIFED 7
+CONSTANT: PAN_MIDLINE_CONSTANT_TRIMMED 8
+CONSTANT: PAN_MIDLINE_CONSTANT_POINTED 9
+CONSTANT: PAN_MIDLINE_CONSTANT_SERIFED 10
+CONSTANT: PAN_MIDLINE_LOW_TRIMMED 11
+CONSTANT: PAN_MIDLINE_LOW_POINTED 12
+CONSTANT: PAN_MIDLINE_LOW_SERIFED 13
+CONSTANT: PAN_XHEIGHT_CONSTANT_SMALL 2
+CONSTANT: PAN_XHEIGHT_CONSTANT_STD 3
+CONSTANT: PAN_XHEIGHT_CONSTANT_LARGE 4
+CONSTANT: PAN_XHEIGHT_DUCKING_SMALL 5
+CONSTANT: PAN_XHEIGHT_DUCKING_STD 6
+CONSTANT: PAN_XHEIGHT_DUCKING_LARGE 7
+CONSTANT: FS_LATIN1 1
+CONSTANT: FS_LATIN2 2
+CONSTANT: FS_CYRILLIC 4
+CONSTANT: FS_GREEK 8
+CONSTANT: FS_TURKISH 16
+CONSTANT: FS_HEBREW 32
+CONSTANT: FS_ARABIC 64
+CONSTANT: FS_BALTIC 128
+CONSTANT: FS_THAI HEX: 10000
+CONSTANT: FS_JISJAPAN HEX: 20000
+CONSTANT: FS_CHINESESIMP HEX: 40000
+CONSTANT: FS_WANSUNG HEX: 80000
+CONSTANT: FS_CHINESETRAD HEX: 100000
+CONSTANT: FS_JOHAB HEX: 200000
+CONSTANT: FS_SYMBOL HEX: 80000000
+CONSTANT: HS_BDIAGONAL 3
+CONSTANT: HS_CROSS 4
+CONSTANT: HS_DIAGCROSS 5
+CONSTANT: HS_FDIAGONAL 2
+CONSTANT: HS_HORIZONTAL 0
+CONSTANT: HS_VERTICAL 1
+CONSTANT: PS_GEOMETRIC 65536
+CONSTANT: PS_COSMETIC 0
+CONSTANT: PS_ALTERNATE 8
+CONSTANT: PS_SOLID 0
+CONSTANT: PS_DASH 1
+CONSTANT: PS_DOT 2
+CONSTANT: PS_DASHDOT 3
+CONSTANT: PS_DASHDOTDOT 4
+CONSTANT: PS_NULL 5
+CONSTANT: PS_USERSTYLE 7
+CONSTANT: PS_INSIDEFRAME 6
+CONSTANT: PS_ENDCAP_ROUND 0
+CONSTANT: PS_ENDCAP_SQUARE 256
+CONSTANT: PS_ENDCAP_FLAT 512
+CONSTANT: PS_JOIN_BEVEL 4096
+CONSTANT: PS_JOIN_MITER 8192
+CONSTANT: PS_JOIN_ROUND 0
+CONSTANT: PS_STYLE_MASK 15
+CONSTANT: PS_ENDCAP_MASK 3840
+CONSTANT: PS_TYPE_MASK 983040
+CONSTANT: ALTERNATE 1
+CONSTANT: WINDING 2
+CONSTANT: DC_BINNAMES 12
+CONSTANT: DC_BINS 6
+CONSTANT: DC_COPIES 18
+CONSTANT: DC_DRIVER 11
+CONSTANT: DC_DATATYPE_PRODUCED 21
+CONSTANT: DC_DUPLEX 7
+CONSTANT: DC_EMF_COMPLIANT 20
+CONSTANT: DC_ENUMRESOLUTIONS 13
+CONSTANT: DC_EXTRA 9
+CONSTANT: DC_FIELDS 1
+CONSTANT: DC_FILEDEPENDENCIES 14
+CONSTANT: DC_MAXEXTENT 5
+CONSTANT: DC_MINEXTENT 4
+CONSTANT: DC_ORIENTATION 17
+CONSTANT: DC_PAPERNAMES 16
+CONSTANT: DC_PAPERS 2
+CONSTANT: DC_PAPERSIZE 3
+CONSTANT: DC_SIZE 8
+CONSTANT: DC_TRUETYPE 15
+CONSTANT: DCTT_BITMAP 1
+CONSTANT: DCTT_DOWNLOAD 2
+CONSTANT: DCTT_SUBDEV 4
+CONSTANT: DCTT_DOWNLOAD_OUTLINE 8
+CONSTANT: DC_VERSION 10
+CONSTANT: DC_BINADJUST 19
+CONSTANT: DC_MANUFACTURER 23
+CONSTANT: DC_MODEL 24
+CONSTANT: DC_PERSONALITY 25
+CONSTANT: DC_PRINTRATE 26
+CONSTANT: DC_PRINTRATEUNIT 27
+CONSTANT: DC_PRINTERMEM 28
+CONSTANT: DC_MEDIAREADY 29
+CONSTANT: DC_STAPLE 30
+CONSTANT: DC_PRINTRATEPPM 31
+CONSTANT: DC_COLORDEVICE 32
+CONSTANT: DC_NUP 33
+CONSTANT: DC_MEDIATYPENAMES 34
+CONSTANT: DC_MEDIATYPES 35
+CONSTANT: DCBA_FACEUPNONE 0
+CONSTANT: DCBA_FACEUPCENTER 1
+CONSTANT: DCBA_FACEUPLEFT 2
+CONSTANT: DCBA_FACEUPRIGHT 3
+CONSTANT: DCBA_FACEDOWNNONE 256
+CONSTANT: DCBA_FACEDOWNCENTER 257
+CONSTANT: DCBA_FACEDOWNLEFT 258
+CONSTANT: DCBA_FACEDOWNRIGHT 259
+CONSTANT: FLOODFILLBORDER 0
+CONSTANT: FLOODFILLSURFACE 1
+CONSTANT: ETO_CLIPPED HEX: 0004
+CONSTANT: ETO_GLYPH_INDEX HEX: 0010
+CONSTANT: ETO_OPAQUE HEX: 0002
+CONSTANT: ETO_NUMERICSLATIN HEX: 0800
+CONSTANT: ETO_NUMERICSLOCAL HEX: 0400
+CONSTANT: ETO_RTLREADING HEX: 0080
+CONSTANT: ETO_IGNORELANGUAGE HEX: 1000
+CONSTANT: ETO_PDY HEX: 2000
+CONSTANT: GDICOMMENT_WINDOWS_METAFILE -2147483647
+CONSTANT: GDICOMMENT_BEGINGROUP 2
+CONSTANT: GDICOMMENT_ENDGROUP 3
+CONSTANT: GDICOMMENT_MULTIFORMATS 1073741828
+CONSTANT: GDICOMMENT_IDENTIFIER 1128875079
+CONSTANT: AD_COUNTERCLOCKWISE 1
+CONSTANT: AD_CLOCKWISE 2
+CONSTANT: RDH_RECTANGLES 1
+CONSTANT: GCPCLASS_LATIN 1
+CONSTANT: GCPCLASS_HEBREW 2
+CONSTANT: GCPCLASS_ARABIC 2
+CONSTANT: GCPCLASS_NEUTRAL 3
+CONSTANT: GCPCLASS_LOCALNUMBER 4
+CONSTANT: GCPCLASS_LATINNUMBER 5
+CONSTANT: GCPCLASS_LATINNUMERICTERMINATOR 6
+CONSTANT: GCPCLASS_LATINNUMERICSEPARATOR 7
+CONSTANT: GCPCLASS_NUMERICSEPARATOR 8
+CONSTANT: GCPCLASS_PREBOUNDLTR 128
+CONSTANT: GCPCLASS_PREBOUNDRTL 64
+CONSTANT: GCPCLASS_POSTBOUNDLTR 32
+CONSTANT: GCPCLASS_POSTBOUNDRTL 16
+CONSTANT: GCPGLYPH_LINKBEFORE HEX: 8000
+CONSTANT: GCPGLYPH_LINKAFTER HEX: 4000
+CONSTANT: DCB_DISABLE 8
+CONSTANT: DCB_ENABLE 4
+CONSTANT: DCB_RESET 1
+CONSTANT: DCB_SET 3
+CONSTANT: DCB_ACCUMULATE 2
+CONSTANT: DCB_DIRTY 2
+CONSTANT: OBJ_BRUSH 2
+CONSTANT: OBJ_PEN 1
+CONSTANT: OBJ_PAL 5
+CONSTANT: OBJ_FONT 6
+CONSTANT: OBJ_BITMAP 7
+CONSTANT: OBJ_EXTPEN 11
+CONSTANT: OBJ_REGION 8
+CONSTANT: OBJ_DC 3
+CONSTANT: OBJ_MEMDC 10
+CONSTANT: OBJ_METAFILE 9
+CONSTANT: OBJ_METADC 4
+CONSTANT: OBJ_ENHMETAFILE 13
+CONSTANT: OBJ_ENHMETADC 12
+CONSTANT: DRIVERVERSION 0
+CONSTANT: TECHNOLOGY 2
+CONSTANT: DT_PLOTTER 0
+CONSTANT: DT_RASDISPLAY 1
+CONSTANT: DT_RASPRINTER 2
+CONSTANT: DT_RASCAMERA 3
+CONSTANT: DT_CHARSTREAM 4
+CONSTANT: DT_METAFILE 5
+CONSTANT: DT_DISPFILE 6
+CONSTANT: HORZSIZE 4
+CONSTANT: VERTSIZE 6
+CONSTANT: HORZRES 8
+CONSTANT: VERTRES 10
+CONSTANT: LOGPIXELSX 88
+CONSTANT: LOGPIXELSY 90
+CONSTANT: BITSPIXEL 12
+CONSTANT: PLANES 14
+CONSTANT: NUMBRUSHES 16
+CONSTANT: NUMPENS 18
+CONSTANT: NUMFONTS 22
+CONSTANT: NUMCOLORS 24
+CONSTANT: NUMMARKERS 20
+CONSTANT: ASPECTX 40
+CONSTANT: ASPECTY 42
+CONSTANT: ASPECTXY 44
+CONSTANT: PDEVICESIZE 26
+CONSTANT: CLIPCAPS 36
+CONSTANT: SIZEPALETTE 104
+CONSTANT: NUMRESERVED 106
+CONSTANT: COLORRES 108
+CONSTANT: PHYSICALWIDTH 110
+CONSTANT: PHYSICALHEIGHT 111
+CONSTANT: PHYSICALOFFSETX 112
+CONSTANT: PHYSICALOFFSETY 113
+CONSTANT: SCALINGFACTORX 114
+CONSTANT: SCALINGFACTORY 115
+CONSTANT: VREFRESH 116
+CONSTANT: DESKTOPHORZRES 118
+CONSTANT: DESKTOPVERTRES 117
+CONSTANT: BLTALIGNMENT 119
+CONSTANT: SHADEBLENDCAPS 120
+CONSTANT: SB_NONE HEX: 00
+CONSTANT: SB_CONST_ALPHA HEX: 01
+CONSTANT: SB_PIXEL_ALPHA HEX: 02
+CONSTANT: SB_PREMULT_ALPHA HEX: 04
+CONSTANT: SB_GRAD_RECT HEX: 10
+CONSTANT: SB_GRAD_TRI HEX: 20
+CONSTANT: COLORMGMTCAPS 121
+CONSTANT: CM_NONE HEX: 00
+CONSTANT: CM_DEVICE_ICM HEX: 01
+CONSTANT: CM_GAMMA_RAMP HEX: 02
+CONSTANT: CM_CMYK_COLOR HEX: 04
+CONSTANT: RASTERCAPS 38
+CONSTANT: RC_BITBLT 1
+CONSTANT: RC_BITMAP64 8
+CONSTANT: RC_DI_BITMAP 128
+CONSTANT: RC_DIBTODEV 512
+CONSTANT: RC_FLOODFILL 4096
+CONSTANT: RC_STRETCHBLT 2048
+CONSTANT: RC_STRETCHDIB 8192
+CONSTANT: CURVECAPS 28
+CONSTANT: CC_NONE 0
+CONSTANT: CC_CIRCLES 1
+CONSTANT: CC_PIE 2
+CONSTANT: CC_CHORD 4
+CONSTANT: CC_ELLIPSES 8
+CONSTANT: CC_WIDE 16
+CONSTANT: CC_STYLED 32
+CONSTANT: CC_WIDESTYLED 64
+CONSTANT: CC_INTERIORS 128
+CONSTANT: CC_ROUNDRECT 256
+CONSTANT: LINECAPS 30
+CONSTANT: LC_NONE 0
+CONSTANT: LC_POLYLINE 2
+CONSTANT: LC_MARKER 4
+CONSTANT: LC_POLYMARKER 8
+CONSTANT: LC_WIDE 16
+CONSTANT: LC_STYLED 32
+CONSTANT: LC_WIDESTYLED 64
+CONSTANT: LC_INTERIORS 128
+CONSTANT: POLYGONALCAPS 32
+CONSTANT: RC_BANDING 2
+CONSTANT: RC_BIGFONT 1024
+CONSTANT: RC_DEVBITS HEX: 8000
+CONSTANT: RC_GDI20_OUTPUT 16
+CONSTANT: RC_GDI20_STATE 32
+CONSTANT: RC_NONE 0
+CONSTANT: RC_OP_DX_OUTPUT HEX: 4000
+CONSTANT: RC_PALETTE 256
+CONSTANT: RC_SAVEBITMAP 64
+CONSTANT: RC_SCALING 4
+CONSTANT: PC_NONE 0
+CONSTANT: PC_POLYGON 1
+CONSTANT: PC_POLYPOLYGON 256
+CONSTANT: PC_PATHS 512
+CONSTANT: PC_RECTANGLE 2
+CONSTANT: PC_WINDPOLYGON 4
+CONSTANT: PC_SCANLINE 8
+CONSTANT: PC_TRAPEZOID 4
+CONSTANT: PC_WIDE 16
+CONSTANT: PC_STYLED 32
+CONSTANT: PC_WIDESTYLED 64
+CONSTANT: PC_INTERIORS 128
+CONSTANT: TEXTCAPS 34
+CONSTANT: TC_OP_CHARACTER 1
+CONSTANT: TC_OP_STROKE 2
+CONSTANT: TC_CP_STROKE 4
+CONSTANT: TC_CR_90 8
+CONSTANT: TC_CR_ANY 16
+CONSTANT: TC_SF_X_YINDEP 32
+CONSTANT: TC_SA_DOUBLE 64
+CONSTANT: TC_SA_INTEGER 128
+CONSTANT: TC_SA_CONTIN 256
+CONSTANT: TC_EA_DOUBLE 512
+CONSTANT: TC_IA_ABLE 1024
+CONSTANT: TC_UA_ABLE 2048
+CONSTANT: TC_SO_ABLE 4096
+CONSTANT: TC_RA_ABLE 8192
+CONSTANT: TC_VA_ABLE 16384
+CONSTANT: TC_RESERVED 32768
+CONSTANT: TC_SCROLLBLT 65536
+CONSTANT: GCP_DBCS 1
+CONSTANT: GCP_ERROR HEX: 8000
+CONSTANT: GCP_CLASSIN HEX: 80000
+CONSTANT: GCP_DIACRITIC 256
+CONSTANT: GCP_DISPLAYZWG HEX: 400000
+CONSTANT: GCP_GLYPHSHAPE 16
+CONSTANT: GCP_JUSTIFY HEX: 10000
+CONSTANT: GCP_JUSTIFYIN HEX: 200000
+CONSTANT: GCP_KASHIDA 1024
+CONSTANT: GCP_LIGATE 32
+CONSTANT: GCP_MAXEXTENT HEX: 100000
+CONSTANT: GCP_NEUTRALOVERRIDE HEX: 2000000
+CONSTANT: GCP_NUMERICOVERRIDE HEX: 1000000
+CONSTANT: GCP_NUMERICSLATIN HEX: 4000000
+CONSTANT: GCP_NUMERICSLOCAL HEX: 8000000
+CONSTANT: GCP_REORDER 2
+CONSTANT: GCP_SYMSWAPOFF HEX: 800000
+CONSTANT: GCP_USEKERNING 8
+CONSTANT: FLI_GLYPHS HEX: 40000
+CONSTANT: FLI_MASK HEX: 103b
+CONSTANT: GGO_METRICS 0
+CONSTANT: GGO_BITMAP 1
+CONSTANT: GGO_NATIVE 2
+CONSTANT: GGO_BEZIER 3
+CONSTANT: GGO_GRAY2_BITMAP 4
+CONSTANT: GGO_GRAY4_BITMAP 5
+CONSTANT: GGO_GRAY8_BITMAP 6
+CONSTANT: GGO_GLYPH_INDEX 128
+CONSTANT: GGO_UNHINTED 256
+CONSTANT: GM_COMPATIBLE 1
+CONSTANT: GM_ADVANCED 2
+CONSTANT: MM_ANISOTROPIC 8
+CONSTANT: MM_HIENGLISH 5
+CONSTANT: MM_HIMETRIC 3
+CONSTANT: MM_ISOTROPIC 7
+CONSTANT: MM_LOENGLISH 4
+CONSTANT: MM_LOMETRIC 2
+CONSTANT: MM_TEXT 1
+CONSTANT: MM_TWIPS 6
+ALIAS: MM_MAX_FIXEDSCALE MM_TWIPS
+CONSTANT: ABSOLUTE 1
+CONSTANT: RELATIVE 2
+CONSTANT: PC_EXPLICIT 2
+CONSTANT: PC_NOCOLLAPSE 4
+CONSTANT: PC_RESERVED 1
+CONSTANT: CLR_NONE HEX: ffffffff
+ALIAS: CLR_INVALID CLR_NONE
+CONSTANT: CLR_DEFAULT HEX: ff000000
+CONSTANT: PT_MOVETO 6
+CONSTANT: PT_LINETO 2
+CONSTANT: PT_BEZIERTO 4
+CONSTANT: PT_CLOSEFIGURE 1
+CONSTANT: TT_AVAILABLE 1
+CONSTANT: TT_ENABLED 2
+CONSTANT: BLACK_BRUSH 4
+CONSTANT: DKGRAY_BRUSH 3
+CONSTANT: GRAY_BRUSH 2
+CONSTANT: HOLLOW_BRUSH 5
+CONSTANT: LTGRAY_BRUSH 1
+CONSTANT: NULL_BRUSH 5
+CONSTANT: WHITE_BRUSH 0
+CONSTANT: BLACK_PEN 7
+CONSTANT: NULL_PEN 8
+CONSTANT: WHITE_PEN 6
+CONSTANT: ANSI_FIXED_FONT 11
+CONSTANT: ANSI_VAR_FONT 12
CONSTANT: DEVICE_DEFAULT_FONT 14
-CONSTANT: DEFAULT_PALETTE 15
-CONSTANT: SYSTEM_FIXED_FONT 16
-CONSTANT: DEFAULT_GUI_FONT 17
-CONSTANT: DC_BRUSH 18
-CONSTANT: DC_PEN 19
-
-CONSTANT: BI_RGB 0
-CONSTANT: BI_RLE8 1
-CONSTANT: BI_RLE4 2
-CONSTANT: BI_BITFIELDS 3
+CONSTANT: DEFAULT_GUI_FONT 17
+CONSTANT: OEM_FIXED_FONT 10
+CONSTANT: SYSTEM_FONT 13
+CONSTANT: SYSTEM_FIXED_FONT 16
+CONSTANT: DEFAULT_PALETTE 15
+CONSTANT: DC_BRUSH 18
+CONSTANT: DC_PEN 19
+CONSTANT: SYSPAL_ERROR 0
+CONSTANT: SYSPAL_STATIC 1
+CONSTANT: SYSPAL_NOSTATIC 2
+CONSTANT: SYSPAL_NOSTATIC256 3
+CONSTANT: TA_BASELINE 24
+CONSTANT: TA_BOTTOM 8
+CONSTANT: TA_TOP 0
+CONSTANT: TA_CENTER 6
+CONSTANT: TA_LEFT 0
+CONSTANT: TA_RIGHT 2
+CONSTANT: TA_RTLREADING 256
+CONSTANT: TA_NOUPDATECP 0
+CONSTANT: TA_UPDATECP 1
+: TA_MASK ( -- n ) { TA_BASELINE TA_CENTER TA_UPDATECP TA_RTLREADING } flags ; foldable
+CONSTANT: VTA_BASELINE 24
+CONSTANT: VTA_CENTER 6
+ALIAS: VTA_LEFT TA_BOTTOM
+ALIAS: VTA_RIGHT TA_TOP
+ALIAS: VTA_BOTTOM TA_RIGHT
+ALIAS: VTA_TOP TA_LEFT
+CONSTANT: MWT_IDENTITY 1
+CONSTANT: MWT_LEFTMULTIPLY 2
+CONSTANT: MWT_RIGHTMULTIPLY 3
+CONSTANT: OPAQUE 2
+CONSTANT: TRANSPARENT 1
+CONSTANT: BLACKONWHITE 1
+CONSTANT: WHITEONBLACK 2
+CONSTANT: COLORONCOLOR 3
+CONSTANT: HALFTONE 4
+CONSTANT: MAXSTRETCHBLTMODE 4
+CONSTANT: STRETCH_ANDSCANS 1
+CONSTANT: STRETCH_DELETESCANS 3
+CONSTANT: STRETCH_HALFTONE 4
+CONSTANT: STRETCH_ORSCANS 2
+CONSTANT: TCI_SRCCHARSET 1
+CONSTANT: TCI_SRCCODEPAGE 2
+CONSTANT: TCI_SRCFONTSIG 3
+CONSTANT: ICM_ON 2
+CONSTANT: ICM_OFF 1
+CONSTANT: ICM_QUERY 3
+CONSTANT: NEWFRAME 1
+CONSTANT: ABORTDOC 2
+CONSTANT: NEXTBAND 3
+CONSTANT: SETCOLORTABLE 4
+CONSTANT: GETCOLORTABLE 5
+CONSTANT: FLUSHOUTPUT 6
+CONSTANT: DRAFTMODE 7
+CONSTANT: QUERYESCSUPPORT 8
+CONSTANT: SETABORTPROC 9
+CONSTANT: STARTDOC 10
+CONSTANT: ENDDOC 11
+CONSTANT: GETPHYSPAGESIZE 12
+CONSTANT: GETPRINTINGOFFSET 13
+CONSTANT: GETSCALINGFACTOR 14
+CONSTANT: MFCOMMENT 15
+CONSTANT: GETPENWIDTH 16
+CONSTANT: SETCOPYCOUNT 17
+CONSTANT: SELECTPAPERSOURCE 18
+CONSTANT: DEVICEDATA 19
+CONSTANT: PASSTHROUGH 19
+CONSTANT: GETTECHNOLGY 20
+CONSTANT: GETTECHNOLOGY 20
+CONSTANT: SETLINECAP 21
+CONSTANT: SETLINEJOIN 22
+CONSTANT: SETMITERLIMIT 23
+CONSTANT: BANDINFO 24
+CONSTANT: DRAWPATTERNRECT 25
+CONSTANT: GETVECTORPENSIZE 26
+CONSTANT: GETVECTORBRUSHSIZE 27
+CONSTANT: ENABLEDUPLEX 28
+CONSTANT: GETSETPAPERBINS 29
+CONSTANT: GETSETPRINTORIENT 30
+CONSTANT: ENUMPAPERBINS 31
+CONSTANT: SETDIBSCALING 32
+CONSTANT: EPSPRINTING 33
+CONSTANT: ENUMPAPERMETRICS 34
+CONSTANT: GETSETPAPERMETRICS 35
+CONSTANT: POSTSCRIPT_DATA 37
+CONSTANT: POSTSCRIPT_IGNORE 38
+CONSTANT: MOUSETRAILS 39
+CONSTANT: GETDEVICEUNITS 42
+CONSTANT: GETEXTENDEDTEXTMETRICS 256
+CONSTANT: GETEXTENTTABLE 257
+CONSTANT: GETPAIRKERNTABLE 258
+CONSTANT: GETTRACKKERNTABLE 259
+CONSTANT: EXTTEXTOUT 512
+CONSTANT: GETFACENAME 513
+CONSTANT: DOWNLOADFACE 514
+CONSTANT: ENABLERELATIVEWIDTHS 768
+CONSTANT: ENABLEPAIRKERNING 769
+CONSTANT: SETKERNTRACK 770
+CONSTANT: SETALLJUSTVALUES 771
+CONSTANT: SETCHARSET 772
+CONSTANT: STRETCHBLT 2048
+CONSTANT: GETSETSCREENPARAMS 3072
+CONSTANT: QUERYDIBSUPPORT 3073
+CONSTANT: BEGIN_PATH 4096
+CONSTANT: CLIP_TO_PATH 4097
+CONSTANT: END_PATH 4098
+CONSTANT: EXT_DEVICE_CAPS 4099
+CONSTANT: RESTORE_CTM 4100
+CONSTANT: SAVE_CTM 4101
+CONSTANT: SET_ARC_DIRECTION 4102
+CONSTANT: SET_BACKGROUND_COLOR 4103
+CONSTANT: SET_POLY_MODE 4104
+CONSTANT: SET_SCREEN_ANGLE 4105
+CONSTANT: SET_SPREAD 4106
+CONSTANT: TRANSFORM_CTM 4107
+CONSTANT: SET_CLIP_BOX 4108
+CONSTANT: SET_BOUNDS 4109
+CONSTANT: SET_MIRROR_MODE 4110
+CONSTANT: OPENCHANNEL 4110
+CONSTANT: DOWNLOADHEADER 4111
+CONSTANT: CLOSECHANNEL 4112
+CONSTANT: POSTSCRIPT_PASSTHROUGH 4115
+CONSTANT: ENCAPSULATED_POSTSCRIPT 4116
+CONSTANT: QDI_SETDIBITS 1
+CONSTANT: QDI_GETDIBITS 2
+CONSTANT: QDI_DIBTOSCREEN 4
+CONSTANT: QDI_STRETCHDIB 8
+CONSTANT: SP_NOTREPORTED HEX: 4000
+CONSTANT: PR_JOBSTATUS 0
+CONSTANT: ASPECT_FILTERING 1
+CONSTANT: BS_SOLID 0
+CONSTANT: BS_NULL 1
+CONSTANT: BS_HOLLOW 1
+CONSTANT: BS_HATCHED 2
+CONSTANT: BS_PATTERN 3
+CONSTANT: BS_INDEXED 4
+CONSTANT: BS_DIBPATTERN 5
+CONSTANT: BS_DIBPATTERNPT 6
+CONSTANT: BS_PATTERN8X8 7
+CONSTANT: BS_DIBPATTERN8X8 8
+CONSTANT: LCS_CALIBRATED_RGB 0
+CONSTANT: LCS_DEVICE_RGB 1
+CONSTANT: LCS_DEVICE_CMYK 2
+CONSTANT: LCS_GM_BUSINESS 1
+CONSTANT: LCS_GM_GRAPHICS 2
+CONSTANT: LCS_GM_IMAGES 4
+CONSTANT: RASTER_FONTTYPE 1
+CONSTANT: DEVICE_FONTTYPE 2
+CONSTANT: TRUETYPE_FONTTYPE 4
+CONSTANT: DMORIENT_PORTRAIT 1
+CONSTANT: DMORIENT_LANDSCAPE 2
+CONSTANT: DMPAPER_FIRST 1
+CONSTANT: DMPAPER_LETTER 1
+CONSTANT: DMPAPER_LETTERSMALL 2
+CONSTANT: DMPAPER_TABLOID 3
+CONSTANT: DMPAPER_LEDGER 4
+CONSTANT: DMPAPER_LEGAL 5
+CONSTANT: DMPAPER_STATEMENT 6
+CONSTANT: DMPAPER_EXECUTIVE 7
+CONSTANT: DMPAPER_A3 8
+CONSTANT: DMPAPER_A4 9
+CONSTANT: DMPAPER_A4SMALL 10
+CONSTANT: DMPAPER_A5 11
+CONSTANT: DMPAPER_B4 12
+CONSTANT: DMPAPER_B5 13
+CONSTANT: DMPAPER_FOLIO 14
+CONSTANT: DMPAPER_QUARTO 15
+CONSTANT: DMPAPER_10X14 16
+CONSTANT: DMPAPER_11X17 17
+CONSTANT: DMPAPER_NOTE 18
+CONSTANT: DMPAPER_ENV_9 19
+CONSTANT: DMPAPER_ENV_10 20
+CONSTANT: DMPAPER_ENV_11 21
+CONSTANT: DMPAPER_ENV_12 22
+CONSTANT: DMPAPER_ENV_14 23
+CONSTANT: DMPAPER_CSHEET 24
+CONSTANT: DMPAPER_DSHEET 25
+CONSTANT: DMPAPER_ESHEET 26
+CONSTANT: DMPAPER_ENV_DL 27
+CONSTANT: DMPAPER_ENV_C5 28
+CONSTANT: DMPAPER_ENV_C3 29
+CONSTANT: DMPAPER_ENV_C4 30
+CONSTANT: DMPAPER_ENV_C6 31
+CONSTANT: DMPAPER_ENV_C65 32
+CONSTANT: DMPAPER_ENV_B4 33
+CONSTANT: DMPAPER_ENV_B5 34
+CONSTANT: DMPAPER_ENV_B6 35
+CONSTANT: DMPAPER_ENV_ITALY 36
+CONSTANT: DMPAPER_ENV_MONARCH 37
+CONSTANT: DMPAPER_ENV_PERSONAL 38
+CONSTANT: DMPAPER_FANFOLD_US 39
+CONSTANT: DMPAPER_FANFOLD_STD_GERMAN 40
+CONSTANT: DMPAPER_FANFOLD_LGL_GERMAN 41
+CONSTANT: DMPAPER_ISO_B4 42
+CONSTANT: DMPAPER_JAPANESE_POSTCARD 43
+CONSTANT: DMPAPER_9X11 44
+CONSTANT: DMPAPER_10X11 45
+CONSTANT: DMPAPER_15X11 46
+CONSTANT: DMPAPER_ENV_INVITE 47
+CONSTANT: DMPAPER_RESERVED_48 48
+CONSTANT: DMPAPER_RESERVED_49 49
+CONSTANT: DMPAPER_LETTER_EXTRA 50
+CONSTANT: DMPAPER_LEGAL_EXTRA 51
+CONSTANT: DMPAPER_TABLOID_EXTRA 52
+CONSTANT: DMPAPER_A4_EXTRA 53
+CONSTANT: DMPAPER_LETTER_TRANSVERSE 54
+CONSTANT: DMPAPER_A4_TRANSVERSE 55
+CONSTANT: DMPAPER_LETTER_EXTRA_TRANSVERSE 56
+CONSTANT: DMPAPER_A_PLUS 57
+CONSTANT: DMPAPER_B_PLUS 58
+CONSTANT: DMPAPER_LETTER_PLUS 59
+CONSTANT: DMPAPER_A4_PLUS 60
+CONSTANT: DMPAPER_A5_TRANSVERSE 61
+CONSTANT: DMPAPER_B5_TRANSVERSE 62
+CONSTANT: DMPAPER_A3_EXTRA 63
+CONSTANT: DMPAPER_A5_EXTRA 64
+CONSTANT: DMPAPER_B5_EXTRA 65
+CONSTANT: DMPAPER_A2 66
+CONSTANT: DMPAPER_A3_TRANSVERSE 67
+CONSTANT: DMPAPER_A3_EXTRA_TRANSVERSE 68
+CONSTANT: DMPAPER_DBL_JAPANESE_POSTCARD 69
+CONSTANT: DMPAPER_A6 70
+CONSTANT: DMPAPER_JENV_KAKU2 71
+CONSTANT: DMPAPER_JENV_KAKU3 72
+CONSTANT: DMPAPER_JENV_CHOU3 73
+CONSTANT: DMPAPER_JENV_CHOU4 74
+CONSTANT: DMPAPER_LETTER_ROTATED 75
+CONSTANT: DMPAPER_A3_ROTATED 76
+CONSTANT: DMPAPER_A4_ROTATED 77
+CONSTANT: DMPAPER_A5_ROTATED 78
+CONSTANT: DMPAPER_B4_JIS_ROTATED 79
+CONSTANT: DMPAPER_B5_JIS_ROTATED 80
+CONSTANT: DMPAPER_JAPANESE_POSTCARD_ROTATED 81
+CONSTANT: DMPAPER_DBL_JAPANESE_POSTCARD_ROTATED 82
+CONSTANT: DMPAPER_A6_ROTATED 83
+CONSTANT: DMPAPER_JENV_KAKU2_ROTATED 84
+CONSTANT: DMPAPER_JENV_KAKU3_ROTATED 85
+CONSTANT: DMPAPER_JENV_CHOU3_ROTATED 86
+CONSTANT: DMPAPER_JENV_CHOU4_ROTATED 87
+CONSTANT: DMPAPER_B6_JIS 88
+CONSTANT: DMPAPER_B6_JIS_ROTATED 89
+CONSTANT: DMPAPER_12X11 90
+CONSTANT: DMPAPER_JENV_YOU4 91
+CONSTANT: DMPAPER_JENV_YOU4_ROTATED 92
+CONSTANT: DMPAPER_P16K 93
+CONSTANT: DMPAPER_P32K 94
+CONSTANT: DMPAPER_P32KBIG 95
+CONSTANT: DMPAPER_PENV_1 96
+CONSTANT: DMPAPER_PENV_2 97
+CONSTANT: DMPAPER_PENV_3 98
+CONSTANT: DMPAPER_PENV_4 99
+CONSTANT: DMPAPER_PENV_5 100
+CONSTANT: DMPAPER_PENV_6 101
+CONSTANT: DMPAPER_PENV_7 102
+CONSTANT: DMPAPER_PENV_8 103
+CONSTANT: DMPAPER_PENV_9 104
+CONSTANT: DMPAPER_PENV_10 105
+CONSTANT: DMPAPER_P16K_ROTATED 106
+CONSTANT: DMPAPER_P32K_ROTATED 107
+CONSTANT: DMPAPER_P32KBIG_ROTATED 108
+CONSTANT: DMPAPER_PENV_1_ROTATED 109
+CONSTANT: DMPAPER_PENV_2_ROTATED 110
+CONSTANT: DMPAPER_PENV_3_ROTATED 111
+CONSTANT: DMPAPER_PENV_4_ROTATED 112
+CONSTANT: DMPAPER_PENV_5_ROTATED 113
+CONSTANT: DMPAPER_PENV_6_ROTATED 114
+CONSTANT: DMPAPER_PENV_7_ROTATED 115
+CONSTANT: DMPAPER_PENV_8_ROTATED 116
+CONSTANT: DMPAPER_PENV_9_ROTATED 117
+CONSTANT: DMPAPER_PENV_10_ROTATED 118
+CONSTANT: DMPAPER_LAST 118
+CONSTANT: DMPAPER_USER 256
+CONSTANT: DMBIN_FIRST 1
+CONSTANT: DMBIN_UPPER 1
+CONSTANT: DMBIN_ONLYONE 1
+CONSTANT: DMBIN_LOWER 2
+CONSTANT: DMBIN_MIDDLE 3
+CONSTANT: DMBIN_MANUAL 4
+CONSTANT: DMBIN_ENVELOPE 5
+CONSTANT: DMBIN_ENVMANUAL 6
+CONSTANT: DMBIN_AUTO 7
+CONSTANT: DMBIN_TRACTOR 8
+CONSTANT: DMBIN_SMALLFMT 9
+CONSTANT: DMBIN_LARGEFMT 10
+CONSTANT: DMBIN_LARGECAPACITY 11
+CONSTANT: DMBIN_CASSETTE 14
+CONSTANT: DMBIN_FORMSOURCE 15
+CONSTANT: DMBIN_LAST 15
+CONSTANT: DMBIN_USER 256
+CONSTANT: DMRES_DRAFT -1
+CONSTANT: DMRES_LOW -2
+CONSTANT: DMRES_MEDIUM -3
+CONSTANT: DMRES_HIGH -4
+CONSTANT: DMCOLOR_MONOCHROME 1
+CONSTANT: DMCOLOR_COLOR 2
+CONSTANT: DMDUP_SIMPLEX 1
+CONSTANT: DMDUP_VERTICAL 2
+CONSTANT: DMDUP_HORIZONTAL 3
+CONSTANT: DMTT_BITMAP 1
+CONSTANT: DMTT_DOWNLOAD 2
+CONSTANT: DMTT_SUBDEV 3
+CONSTANT: DMTT_DOWNLOAD_OUTLINE 4
+CONSTANT: DMCOLLATE_FALSE 0
+CONSTANT: DMCOLLATE_TRUE 1
+CONSTANT: DM_SPECVERSION 800
+CONSTANT: DM_GRAYSCALE 1
+CONSTANT: DM_INTERLACED 2
+CONSTANT: DM_UPDATE 1
+CONSTANT: DM_COPY 2
+CONSTANT: DM_PROMPT 4
+CONSTANT: DM_MODIFY 8
+ALIAS: DM_IN_BUFFER DM_MODIFY
+ALIAS: DM_IN_PROMPT DM_PROMPT
+ALIAS: DM_OUT_BUFFER DM_COPY
+ALIAS: DM_OUT_DEFAULT DM_UPDATE
+CONSTANT: DM_ORIENTATION HEX: 00000001
+CONSTANT: DM_PAPERSIZE HEX: 00000002
+CONSTANT: DM_PAPERLENGTH HEX: 00000004
+CONSTANT: DM_PAPERWIDTH HEX: 00000008
+CONSTANT: DM_SCALE HEX: 00000010
+CONSTANT: DM_POSITION HEX: 00000020
+CONSTANT: DM_COPIES HEX: 00000100
+CONSTANT: DM_DEFAULTSOURCE HEX: 00000200
+CONSTANT: DM_PRINTQUALITY HEX: 00000400
+CONSTANT: DM_COLOR HEX: 00000800
+CONSTANT: DM_DUPLEX HEX: 00001000
+CONSTANT: DM_YRESOLUTION HEX: 00002000
+CONSTANT: DM_TTOPTION HEX: 00004000
+CONSTANT: DM_COLLATE HEX: 00008000
+CONSTANT: DM_FORMNAME HEX: 00010000
+CONSTANT: DM_LOGPIXELS HEX: 00020000
+CONSTANT: DM_BITSPERPEL HEX: 00040000
+CONSTANT: DM_PELSWIDTH HEX: 00080000
+CONSTANT: DM_PELSHEIGHT HEX: 00100000
+CONSTANT: DM_DISPLAYFLAGS HEX: 00200000
+CONSTANT: DM_DISPLAYFREQUENCY HEX: 00400000
+CONSTANT: DM_ICMMETHOD HEX: 00800000
+CONSTANT: DM_ICMINTENT HEX: 01000000
+CONSTANT: DM_MEDIATYPE HEX: 02000000
+CONSTANT: DM_DITHERTYPE HEX: 04000000
+CONSTANT: DM_PANNINGWIDTH HEX: 08000000
+CONSTANT: DM_PANNINGHEIGHT HEX: 10000000
+CONSTANT: DM_DISPLAYFIXEDOUTPUT HEX: 20000000
+CONSTANT: DM_DISPLAYORIENTATION HEX: 00000080
+CONSTANT: DMDO_DEFAULT HEX: 00000000
+CONSTANT: DMDO_90 HEX: 00000001
+CONSTANT: DMDO_180 HEX: 00000002
+CONSTANT: DMDO_270 HEX: 00000003
+CONSTANT: DMDFO_DEFAULT HEX: 00000000
+CONSTANT: DMDFO_STRETCH HEX: 00000001
+CONSTANT: DMDFO_CENTER HEX: 00000002
+CONSTANT: DMICMMETHOD_NONE 1
+CONSTANT: DMICMMETHOD_SYSTEM 2
+CONSTANT: DMICMMETHOD_DRIVER 3
+CONSTANT: DMICMMETHOD_DEVICE 4
+CONSTANT: DMICMMETHOD_USER 256
+CONSTANT: DMICM_SATURATE 1
+CONSTANT: DMICM_CONTRAST 2
+CONSTANT: DMICM_COLORMETRIC 3
+CONSTANT: DMICM_USER 256
+CONSTANT: DMMEDIA_STANDARD 1
+CONSTANT: DMMEDIA_TRANSPARENCY 2
+CONSTANT: DMMEDIA_GLOSSY 3
+CONSTANT: DMMEDIA_USER 256
+CONSTANT: DMDITHER_NONE 1
+CONSTANT: DMDITHER_COARSE 2
+CONSTANT: DMDITHER_FINE 3
+CONSTANT: DMDITHER_LINEART 4
+CONSTANT: DMDITHER_ERRORDIFFUSION 5
+CONSTANT: DMDITHER_RESERVED6 6
+CONSTANT: DMDITHER_RESERVED7 7
+CONSTANT: DMDITHER_RESERVED8 8
+CONSTANT: DMDITHER_RESERVED9 9
+CONSTANT: DMDITHER_GRAYSCALE 10
+CONSTANT: DMDITHER_USER 256
+CONSTANT: GDI_ERROR HEX: FFFFFFFF
+: HGDI_ERROR ( -- alien ) GDI_ERROR <alien> ; inline
+CONSTANT: TMPF_FIXED_PITCH 1
+CONSTANT: TMPF_VECTOR 2
+CONSTANT: TMPF_TRUETYPE 4
+CONSTANT: TMPF_DEVICE 8
+CONSTANT: NTM_ITALIC 1
+CONSTANT: NTM_BOLD 32
+CONSTANT: NTM_REGULAR 64
+CONSTANT: TT_POLYGON_TYPE 24
+CONSTANT: TT_PRIM_LINE 1
+CONSTANT: TT_PRIM_QSPLINE 2
+CONSTANT: TT_PRIM_CSPLINE 3
+CONSTANT: FONTMAPPER_MAX 10
+CONSTANT: ENHMETA_STOCK_OBJECT HEX: 80000000
+CONSTANT: WGL_FONT_LINES 0
+CONSTANT: WGL_FONT_POLYGONS 1
+CONSTANT: LPD_DOUBLEBUFFER 1
+CONSTANT: LPD_STEREO 2
+CONSTANT: LPD_SUPPORT_GDI 16
+CONSTANT: LPD_SUPPORT_OPENGL 32
+CONSTANT: LPD_SHARE_DEPTH 64
+CONSTANT: LPD_SHARE_STENCIL 128
+CONSTANT: LPD_SHARE_ACCUM 256
+CONSTANT: LPD_SWAP_EXCHANGE 512
+CONSTANT: LPD_SWAP_COPY 1024
+CONSTANT: LPD_TRANSPARENT 4096
+CONSTANT: LPD_TYPE_RGBA 0
+CONSTANT: LPD_TYPE_COLORINDEX 1
+CONSTANT: WGL_SWAP_MAIN_PLANE 1
+CONSTANT: WGL_SWAP_OVERLAY1 2
+CONSTANT: WGL_SWAP_OVERLAY2 4
+CONSTANT: WGL_SWAP_OVERLAY3 8
+CONSTANT: WGL_SWAP_OVERLAY4 16
+CONSTANT: WGL_SWAP_OVERLAY5 32
+CONSTANT: WGL_SWAP_OVERLAY6 64
+CONSTANT: WGL_SWAP_OVERLAY7 128
+CONSTANT: WGL_SWAP_OVERLAY8 256
+CONSTANT: WGL_SWAP_OVERLAY9 512
+CONSTANT: WGL_SWAP_OVERLAY10 1024
+CONSTANT: WGL_SWAP_OVERLAY11 2048
+CONSTANT: WGL_SWAP_OVERLAY12 4096
+CONSTANT: WGL_SWAP_OVERLAY13 8192
+CONSTANT: WGL_SWAP_OVERLAY14 16384
+CONSTANT: WGL_SWAP_OVERLAY15 32768
+CONSTANT: WGL_SWAP_UNDERLAY1 65536
+CONSTANT: WGL_SWAP_UNDERLAY2 HEX: 20000
+CONSTANT: WGL_SWAP_UNDERLAY3 HEX: 40000
+CONSTANT: WGL_SWAP_UNDERLAY4 HEX: 80000
+CONSTANT: WGL_SWAP_UNDERLAY5 HEX: 100000
+CONSTANT: WGL_SWAP_UNDERLAY6 HEX: 200000
+CONSTANT: WGL_SWAP_UNDERLAY7 HEX: 400000
+CONSTANT: WGL_SWAP_UNDERLAY8 HEX: 800000
+CONSTANT: WGL_SWAP_UNDERLAY9 HEX: 1000000
+CONSTANT: WGL_SWAP_UNDERLAY10 HEX: 2000000
+CONSTANT: WGL_SWAP_UNDERLAY11 HEX: 4000000
+CONSTANT: WGL_SWAP_UNDERLAY12 HEX: 8000000
+CONSTANT: WGL_SWAP_UNDERLAY13 HEX: 10000000
+CONSTANT: WGL_SWAP_UNDERLAY14 HEX: 20000000
+CONSTANT: WGL_SWAP_UNDERLAY15 HEX: 40000000
+CONSTANT: AC_SRC_OVER HEX: 00
+CONSTANT: AC_SRC_ALPHA HEX: 01
+CONSTANT: AC_SRC_NO_PREMULT_ALPHA HEX: 01
+CONSTANT: AC_SRC_NO_ALPHA HEX: 02
+CONSTANT: AC_DST_NO_PREMULT_ALPHA HEX: 10
+CONSTANT: AC_DST_NO_ALPHA HEX: 20
+CONSTANT: LAYOUT_RTL 1
+CONSTANT: LAYOUT_BITMAPORIENTATIONPRESERVED 8
+CONSTANT: CS_ENABLE HEX: 00000001
+CONSTANT: CS_DISABLE HEX: 00000002
+CONSTANT: CS_DELETE_TRANSFORM HEX: 00000003
+CONSTANT: GRADIENT_FILL_RECT_H HEX: 00
+CONSTANT: GRADIENT_FILL_RECT_V HEX: 01
+CONSTANT: GRADIENT_FILL_TRIANGLE HEX: 02
+CONSTANT: GRADIENT_FILL_OP_FLAG HEX: ff
+CONSTANT: COLORMATCHTOTARGET_EMBEDED HEX: 00000001
+CONSTANT: CREATECOLORSPACE_EMBEDED HEX: 00000001
+CONSTANT: SETICMPROFILE_EMBEDED HEX: 00000001
-CONSTANT: DIB_RGB_COLORS 0
-CONSTANT: DIB_PAL_COLORS 1
+CONSTANT: DISPLAY_DEVICE_ATTACHED_TO_DESKTOP HEX: 00000001
+CONSTANT: DISPLAY_DEVICE_MULTI_DRIVER HEX: 00000002
+CONSTANT: DISPLAY_DEVICE_PRIMARY_DEVICE HEX: 00000004
+CONSTANT: DISPLAY_DEVICE_MIRRORING_DRIVER HEX: 00000008
+CONSTANT: DISPLAY_DEVICE_VGA_COMPATIBLE HEX: 00000010
+CONSTANT: DISPLAY_DEVICE_REMOVABLE HEX: 00000020
+CONSTANT: DISPLAY_DEVICE_MODESPRUNED HEX: 08000000
+
+CONSTANT: NTM_NONNEGATIVE_AC HEX: 00010000
+CONSTANT: NTM_PS_OPENTYPE HEX: 00020000
+CONSTANT: NTM_TT_OPENTYPE HEX: 00040000
+CONSTANT: NTM_MULTIPLEMASTER HEX: 00080000
+CONSTANT: NTM_TYPE1 HEX: 00100000
+CONSTANT: NTM_DSIG HEX: 00200000
+
+CONSTANT: GGI_MARK_NONEXISTING_GLYPHS 1
LIBRARY: gdi32
+! FUNCTION: AbortDoc
! FUNCTION: AbortPath
! FUNCTION: AddFontMemResourceEx
! FUNCTION: AddFontResourceA
! FUNCTION: CreateFontIndirectExA
! FUNCTION: CreateFontIndirectExW
! FUNCTION: CreateFontIndirectW
-! FUNCTION: CreateFontW
+FUNCTION: HFONT CreateFontW ( int nHeight, int nWidth, int nEscapement, int nOrientation, int fnWeight, DWORD fdwItalic, DWORD fdwUnderline, DWORD fdwStrikeOut, DWORD fdwCharSet, DWORD fdwOutputPrecision, DWORD fdwClipPrecision, DWORD fdwQuality, DWORD fdwPitchAndFamily, LPCTSTR lpszFace ) ;
+ALIAS: CreateFont CreateFontW
! FUNCTION: CreateHalftonePalette
! FUNCTION: CreateHatchBrush
! FUNCTION: CreateICA
! FUNCTION: CreateRoundRectRgn
! FUNCTION: CreateScalableFontResourceA
! FUNCTION: CreateScalableFontResourceW
-! FUNCTION: CreateSolidBrush
+FUNCTION: HBRUSH CreateSolidBrush ( COLORREF colorref ) ;
! FUNCTION: DdEntry0
! FUNCTION: DdEntry1
! FUNCTION: DdEntry10
! FUNCTION: DdEntry9
! FUNCTION: DeleteColorSpace
FUNCTION: BOOL DeleteDC ( HDC hdc ) ;
+DESTRUCTOR: DeleteDC
! FUNCTION: DeleteEnhMetaFile
! FUNCTION: DeleteMetaFile
FUNCTION: BOOL DeleteObject ( HGDIOBJ hObject ) ;
+DESTRUCTOR: DeleteObject
! FUNCTION: DescribePixelFormat
! FUNCTION: DeviceCapabilitiesExA
! FUNCTION: DeviceCapabilitiesExW
! FUNCTION: ExtFloodFill
! FUNCTION: ExtSelectClipRgn
! FUNCTION: ExtTextOutA
-! FUNCTION: ExtTextOutW
+FUNCTION: BOOL ExtTextOutW ( HDC hdc, int X, int Y, UINT fuOptions, RECT* lprc, LPCTSTR lpString, UINT cbCount, INT* lpDx ) ;
+ALIAS: ExtTextOut ExtTextOutW
! FUNCTION: FillPath
+FUNCTION: int FillRect ( HDC hDC, RECT* lprc, HBRUSH hbr ) ;
! FUNCTION: FillRgn
! FUNCTION: FixBrushOrgEx
! FUNCTION: FlattenPath
! FUNCTION: GetTextFaceAliasW
! FUNCTION: GetTextFaceW
! FUNCTION: GetTextMetricsA
-! FUNCTION: GetTextMetricsW
+FUNCTION: BOOL GetTextMetricsW ( HDC hdc, LPTEXTMETRIC lptm ) ;
+ALIAS: GetTextMetrics GetTextMetricsW
! FUNCTION: GetTransform
! FUNCTION: GetViewportExtEx
! FUNCTION: GetViewportOrgEx
! FUNCTION: PtVisible
! FUNCTION: QueryFontAssocStatus
! FUNCTION: RealizePalette
-! FUNCTION: Rectangle
+FUNCTION: BOOL Rectangle ( HDC hdc, int x, int y, int w, int h ) ;
! FUNCTION: RectInRegion
! FUNCTION: RectVisible
! FUNCTION: RemoveFontMemResourceEx
! FUNCTION: SetBitmapAttributes
! FUNCTION: SetBitmapBits
! FUNCTION: SetBitmapDimensionEx
-! FUNCTION: SetBkColor
+FUNCTION: COLORREF SetBkColor ( HDC hdc, COLORREF color ) ;
! FUNCTION: SetBkMode
! FUNCTION: SetBoundsRect
! FUNCTION: SetBrushAttributes
! FUNCTION: SetBrushOrgEx
! FUNCTION: SetColorAdjustment
! FUNCTION: SetColorSpace
-! FUNCTION: SetDCBrushColor
-! FUNCTION: SetDCPenColor
+FUNCTION: COLORREF SetDCBrushColor ( HDC hdc, COLORREF color ) ;
+FUNCTION: COLORREF SetDCPenColor ( HDC hdc, COLORREF color ) ;
! FUNCTION: SetDeviceGammaRamp
! FUNCTION: SetDIBColorTable
! FUNCTION: SetDIBits
! FUNCTION: SetSystemPaletteUse
! FUNCTION: SetTextAlign
! FUNCTION: SetTextCharacterExtra
-! FUNCTION: SetTextColor
+FUNCTION: COLORREF SetTextColor ( HDC hdc, COLORREF crColor ) ;
+! FUNCTION: SetTextColor ( HDC hDC,
! FUNCTION: SetTextJustification
! FUNCTION: SetViewportExtEx
! FUNCTION: SetViewportOrgEx
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+IN: windows.offscreen.tests\r
+USING: windows.offscreen effects tools.test kernel images ;\r
+\r
+{ 1 1 } [ [ [ ] make-bitmap-image ] with-memory-dc ] must-infer-as\r
+[ t ] [ [ { 10 10 } swap [ ] make-bitmap-image ] with-memory-dc image? ] unit-test\r
--- /dev/null
+! Copyright (C) 2009 Joe Groff, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types kernel combinators sequences
+math windows.gdi32 windows.types images destructors
+accessors fry locals ;
+IN: windows.offscreen
+
+: (bitmap-info) ( dim -- BITMAPINFO )
+ "BITMAPINFO" <c-object> [
+ BITMAPINFO-bmiHeader {
+ [ nip "BITMAPINFOHEADER" heap-size swap set-BITMAPINFOHEADER-biSize ]
+ [ [ first ] dip set-BITMAPINFOHEADER-biWidth ]
+ [ [ second ] dip set-BITMAPINFOHEADER-biHeight ]
+ [ nip 1 swap set-BITMAPINFOHEADER-biPlanes ]
+ [ nip 32 swap set-BITMAPINFOHEADER-biBitCount ]
+ [ nip BI_RGB swap set-BITMAPINFOHEADER-biCompression ]
+ [ [ first2 * 4 * ] dip set-BITMAPINFOHEADER-biSizeImage ]
+ [ nip 72 swap set-BITMAPINFOHEADER-biXPelsPerMeter ]
+ [ nip 72 swap set-BITMAPINFOHEADER-biYPelsPerMeter ]
+ [ nip 0 swap set-BITMAPINFOHEADER-biClrUsed ]
+ [ nip 0 swap set-BITMAPINFOHEADER-biClrImportant ]
+ } 2cleave
+ ] keep ;
+
+: make-bitmap ( dim dc -- hBitmap bits )
+ [ nip ]
+ [
+ swap (bitmap-info) DIB_RGB_COLORS f <void*>
+ [ f 0 CreateDIBSection ] keep *void*
+ ] 2bi
+ [ [ SelectObject drop ] keep ] dip ;
+
+: make-offscreen-dc-and-bitmap ( dim -- dc hBitmap bits )
+ [ f CreateCompatibleDC ] dip over make-bitmap ;
+
+: bitmap>byte-array ( bits dim -- byte-array )
+ product 4 * memory>byte-array ;
+
+: bitmap>image ( bits dim -- image )
+ [ bitmap>byte-array ] keep
+ <image>
+ swap >>dim
+ swap >>bitmap
+ BGRX >>component-order
+ t >>upside-down? ;
+
+: with-memory-dc ( quot: ( hDC -- ) -- )
+ [ [ f CreateCompatibleDC &DeleteDC ] dip call ] with-destructors ; inline
+
+:: make-bitmap-image ( dim dc quot -- image )
+ dim dc make-bitmap [ &DeleteObject drop ] dip
+ quot dip
+ dim bitmap>image ; inline
\ No newline at end of file
--- /dev/null
+Utility words for memory DCs and bitmaps\r
--- /dev/null
+unportable\r
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax namespaces kernel words ;
+USING: alien alien.c-types alien.syntax namespaces kernel words
+sequences math math.bitwise math.vectors colors ;
IN: windows.types
TYPEDEF: char CHAR
{ "LONG" "right" }
{ "LONG" "bottom" } ;
-! C-STRUCT: PAINTSTRUCT
- ! { "HDC" " hdc" }
- ! { "BOOL" "fErase" }
- ! { "RECT" "rcPaint" }
- ! { "BOOL" "fRestore" }
- ! { "BOOL" "fIncUpdate" }
- ! { "BYTE[32]" "rgbReserved" }
-! ;
+C-STRUCT: PAINTSTRUCT
+ { "HDC" " hdc" }
+ { "BOOL" "fErase" }
+ { "RECT" "rcPaint" }
+ { "BOOL" "fRestore" }
+ { "BOOL" "fIncUpdate" }
+ { "BYTE[32]" "rgbReserved" }
+;
C-STRUCT: BITMAPINFOHEADER
{ "DWORD" "biSize" }
{ "LONG" "x" }
{ "LONG" "y" } ;
+C-STRUCT: SIZE
+ { "LONG" "cx" }
+ { "LONG" "cy" } ;
+
C-STRUCT: MSG
{ "HWND" "hWnd" }
{ "UINT" "message" }
{ "LONG" "right" }
{ "LONG" "bottom" } ;
+: <RECT> ( loc dim -- RECT )
+ over v+
+ "RECT" <c-object>
+ over first over set-RECT-right
+ swap second over set-RECT-bottom
+ over first over set-RECT-left
+ swap second over set-RECT-top ;
+
TYPEDEF: RECT* PRECT
TYPEDEF: RECT* LPRECT
TYPEDEF: PIXELFORMATDESCRIPTOR PFD
{ "WORD" "key" }
{ "WORD" "cmd" } ;
TYPEDEF: ACCEL* LPACCEL
+
+TYPEDEF: DWORD COLORREF
+TYPEDEF: DWORD* LPCOLORREF
+
+: RGB ( r g b -- COLORREF )
+ { 16 8 0 } bitfield ; inline
+
+: color>RGB ( color -- COLORREF )
+ >rgba-components drop [ 255 * >integer ] tri@ RGB ;
+
+C-STRUCT: TEXTMETRICW
+ { "LONG" "tmHeight" }
+ { "LONG" "tmAscent" }
+ { "LONG" "tmDescent" }
+ { "LONG" "tmInternalLeading" }
+ { "LONG" "tmExternalLeading" }
+ { "LONG" "tmAveCharWidth" }
+ { "LONG" "tmMaxCharWidth" }
+ { "LONG" "tmWeight" }
+ { "LONG" "tmOverhang" }
+ { "LONG" "tmDigitizedAspectX" }
+ { "LONG" "tmDigitizedAspectY" }
+ { "WCHAR" "tmFirstChar" }
+ { "WCHAR" "tmLastChar" }
+ { "WCHAR" "tmDefaultChar" }
+ { "WCHAR" "tmBreakChar" }
+ { "BYTE" "tmItalic" }
+ { "BYTE" "tmUnderlined" }
+ { "BYTE" "tmStruckOut" }
+ { "BYTE" "tmPitchAndFamily" }
+ { "BYTE" "tmCharSet" } ;
+
+TYPEDEF: TEXTMETRICW* LPTEXTMETRIC
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+High-level wrapper around Uniscribe binding\r
--- /dev/null
+unportable\r
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel assocs math sequences fry io.encodings.string
+io.encodings.utf16n accessors arrays combinators destructors locals
+cache namespaces init images.normalization fonts alien.c-types
+windows windows.usp10 windows.offscreen windows.gdi32
+windows.ole32 windows.types windows.fonts opengl.textures ;
+IN: windows.uniscribe
+
+TUPLE: script-string font string metrics ssa size image disposed ;
+
+: line-offset>x ( n script-string -- x )
+ 2dup string>> length = [
+ ssa>> ! ssa
+ swap 1- ! icp
+ TRUE ! fTrailing
+ ] [
+ ssa>>
+ swap ! icp
+ FALSE ! fTrailing
+ ] if
+ 0 <int> [ ScriptStringCPtoX ole32-error ] keep *int ;
+
+: x>line-offset ( x script-string -- n trailing )
+ ssa>> ! ssa
+ swap ! iX
+ 0 <int> ! pCh
+ 0 <int> ! piTrailing
+ [ ScriptStringXtoCP ole32-error ] 2keep [ *int ] bi@ ;
+
+<PRIVATE
+
+: make-script-string ( dc string -- script-string )
+ dup selection? [ string>> ] when
+ [ utf16n encode ] ! pString
+ [ length ] bi ! cString
+ dup 1.5 * 16 + >integer ! cGlyphs -- MSDN says this is "recommended size"
+ -1 ! iCharset -- Unicode
+ SSA_GLYPHS ! dwFlags
+ 0 ! iReqWidth
+ f ! psControl
+ f ! psState
+ f ! piDx
+ f ! pTabdef
+ f ! pbInClass
+ f <void*> ! pssa
+ [ ScriptStringAnalyse ] keep
+ [ ole32-error ] [ |ScriptStringFree *void* ] bi* ;
+
+: set-dc-colors ( dc font -- )
+ [ background>> color>RGB SetBkColor drop ]
+ [ foreground>> color>RGB SetTextColor drop ] 2bi ;
+
+: selection-start/end ( script-string -- iMinSel iMaxSel )
+ string>> dup selection? [ [ start>> ] [ end>> ] bi ] [ drop 0 0 ] if ;
+
+: (draw-script-string) ( script-string -- )
+ [
+ ssa>> ! ssa
+ 0 ! iX
+ 0 ! iY
+ 0 ! uOptions
+ f ! prc
+ ]
+ [ selection-start/end ] bi
+ ! iMinSel
+ ! iMaxSel
+ FALSE ! fDisabled
+ ScriptStringOut ole32-error ;
+
+: draw-script-string ( dc script-string -- )
+ [ font>> set-dc-colors ] keep (draw-script-string) ;
+
+: script-string-bitmap-size ( script-string -- dim )
+ size>> dup small-texture? [ [ next-power-of-2 ] map ] when ;
+
+:: make-script-string-image ( dc script-string -- image )
+ script-string script-string-bitmap-size dc
+ [ dc script-string draw-script-string ] make-bitmap-image ;
+
+: set-dc-font ( dc font -- )
+ cache-font SelectObject win32-error=0/f ;
+
+: script-string-size ( script-string -- dim )
+ ssa>> ScriptString_pSize
+ dup win32-error=0/f
+ [ SIZE-cx ] [ SIZE-cy ] bi 2array ;
+
+: dc-metrics ( dc -- metrics )
+ "TEXTMETRICW" <c-object>
+ [ GetTextMetrics drop ] keep
+ TEXTMETRIC>metrics ;
+
+: <script-string> ( font string -- script-string )
+ [ script-string new ] 2dip
+ [ >>font ] [ >>string ] bi*
+ [
+ {
+ [ over font>> set-dc-font ]
+ [ dc-metrics >>metrics ]
+ [ over string>> make-script-string >>ssa ]
+ [ drop dup script-string-size >>size ]
+ [ over make-script-string-image >>image ]
+ } cleave
+ ] with-memory-dc ;
+
+PRIVATE>
+
+M: script-string dispose*
+ ssa>> <void*> ScriptStringFree ole32-error ;
+
+SYMBOL: cached-script-strings
+
+: cached-script-string ( string font -- script-string )
+ cached-script-strings get-global [ <script-string> ] 2cache ;
+
+[ <cache-assoc> cached-script-strings set-global ]
+"windows.uniscribe" add-init-hook
\ No newline at end of file
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.syntax alien.destructors ;
IN: windows.usp10
LIBRARY: usp10
SCRIPT_STRING_ANALYSIS* pssa
) ;
+DESTRUCTOR: ScriptStringFree
+
FUNCTION: SIZE* ScriptString_pSize ( SCRIPT_STRING_ANALYSIS ssa ) ;
FUNCTION: int* ScriptString_pcOutChars ( SCRIPT_STRING_ANALYSIS ssa ) ;
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax alien.c-types alien.strings arrays
-combinators kernel math namespaces parser prettyprint sequences
+combinators kernel math namespaces parser sequences
windows.errors windows.types windows.kernel32 words
io.encodings.utf16n ;
IN: windows
+++ /dev/null
-libcairo-2.dll
-libgio-2.0-0.dll
-libglib-2.0-0.dll
-libgmodule-2.0-0.dll
-libgobject-2.0-0.dll
-libgthread-2.0-0.dll
-libpango-1.0-0.dll
-libpangocairo-1.0-0.dll
-libpangowin32-1.0-0.dll
-libpng12-0.dll
-libtiff3.dll
-zlib1.dll
check_ret $DOWNLOADER
}
-maybe_download_dlls() {
- if [[ $OS == winnt ]] ; then
- for file in `cat build-support/dlls.txt`; do
- get_url http://factorcode.org/dlls/$file
- chmod 777 *.dll
- check_ret chmod
- done
- fi
-}
-
get_config_info() {
find_build_info
check_installed_programs
cd_factor
make_factor
get_boot_image
- maybe_download_dlls
bootstrap
}
update) update; update_bootstrap ;;
bootstrap) get_config_info; bootstrap ;;
report) find_build_info ;;
- dlls) get_config_info; maybe_download_dlls;;
net-bootstrap) get_config_info; update_boot_images; bootstrap ;;
make-target) ECHO=false; find_build_info; echo $MAKE_TARGET ;;
*) usage ;;
{ "fputc" "io.streams.c" (( ch alien -- )) }
{ "fwrite" "io.streams.c" (( string alien -- )) }
{ "fflush" "io.streams.c" (( alien -- )) }
+ { "fseek" "io.streams.c" (( alien offset whence -- )) }
{ "fclose" "io.streams.c" (( alien -- )) }
{ "<wrapper>" "kernel" (( obj -- wrapper )) }
{ "(clone)" "kernel" (( obj -- newobj )) }
scan {
{ "(" [ ")" parse-effect ] }
{ f [ ")" unexpected-eof ] }
+ [ bad-effect ]
} case 2array
] when
] if
"(" expect ")" parse-effect ;
: parse-call( ( accum word -- accum )
- [ ")" parse-effect ] dip 2array over push-all ;
\ No newline at end of file
+ [ ")" parse-effect ] dip 2array over push-all ;
: grow-hash ( hash -- )
[ [ >alist ] [ assoc-size 1+ ] bi ] keep
[ reset-hash ] keep
- swap (rehash) ; inline
+ swap (rehash) ;
: ?grow-hash ( hash -- )
dup hash-large? [
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 ;
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private namespaces make io io.encodings
sequences math generic threads.private classes io.backend
-io.files continuations destructors byte-arrays accessors ;
+io.files continuations destructors byte-arrays accessors
+combinators ;
IN: io.streams.c
-TUPLE: c-writer handle disposed ;
+TUPLE: c-stream handle disposed ;
+
+M: c-stream dispose* handle>> fclose ;
+
+M: c-stream stream-seek
+ handle>> swap {
+ { seek-absolute [ 0 ] }
+ { seek-relative [ 1 ] }
+ { seek-end [ 2 ] }
+ [ bad-seek-type ]
+ } case fseek ;
+
+TUPLE: c-writer < c-stream ;
: <c-writer> ( handle -- stream ) f c-writer boa ;
M: c-writer stream-flush dup check-disposed handle>> fflush ;
-M: c-writer dispose* handle>> fclose ;
-
-TUPLE: c-reader handle disposed ;
+TUPLE: c-reader < c-stream ;
: <c-reader> ( handle -- stream ) f c-reader boa ;
[ swap read-until-loop ] B{ } make swap
over empty? over not and [ 2drop f f ] when ;
-M: c-reader dispose*
- handle>> fclose ;
-
M: c-io-backend init-io ;
: stdin-handle ( -- alien ) 11 getenv ;
: bind ( ns quot -- ) swap >n call ndrop ; inline
: counter ( variable -- n ) global [ 0 or 1+ dup ] change-at ;
: make-assoc ( quot exemplar -- hash ) 20 swap new-assoc [ swap bind ] keep ; inline
-: with-scope ( quot -- ) H{ } clone swap bind ; inline
+: with-scope ( quot -- ) 5 <hashtable> swap bind ; inline
: with-variable ( value key quot -- ) [ associate ] dip bind ; inline
: initialize ( variable quot -- ) [ global ] dip [ unless* ] curry change-at ; inline
\ No newline at end of file
"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 ] [
] define-core-syntax
"CONSTANT:" [
- CREATE scan-object define-constant
+ CREATE-WORD scan-object define-constant
] define-core-syntax
":" [
--- /dev/null
+USING: math eval tools.test effects ;
+IN: words.alias.tests
+
+ALIAS: foo +
+[ ] [ "IN: words.alias.tests CONSTANT: foo 5" eval ] unit-test
+[ (( -- value )) ] [ \ foo stack-effect ] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io.streams.string assocs
+heaps.private ;
+IN: assoc-heaps
+
+HELP: <assoc-heap>
+{ $values { "assoc" assoc } { "heap" heap } { "assoc-heap" assoc-heap } }
+{ $description "Constructs a new " { $link assoc-heap } " from two existing data structures." } ;
+
+HELP: <unique-max-heap>
+{ $values { "unique-heap" assoc-heap } }
+{ $description "Creates a new " { $link assoc-heap } " where the assoc is a hashtable and the heap is a max-heap. Popping an element from the heap leaves this element in the hashtable to ensure that the element will not be processed again." } ;
+
+HELP: <unique-min-heap>
+{ $values { "unique-heap" assoc-heap } }
+{ $description "Creates a new " { $link assoc-heap } " where the assoc is a hashtable and the heap is a min-heap. Popping an element from the heap leaves this element in the hashtable to ensure that the element will not be processed again." } ;
+
+{ <unique-max-heap> <unique-min-heap> } related-words
+
+HELP: assoc-heap
+{ $description "A data structure containing an assoc and a heap to get certain properties with better time constraints at the expense of more space and complexity. For instance, a hashtable and a heap can be combined into one assoc-heap to get a sorted data structure with O(1) lookup. Operations on assoc-heap may update both the assoc and the heap or leave them out of sync if it's advantageous." } ;
+
+ARTICLE: "assoc-heaps" "Associative heaps"
+"The " { $vocab-link "assoc-heaps" } " vocabulary combines exists to synthesize data structures with better time properties than either of the two component data structures alone." $nl
+"Associative heap constructor:"
+{ $subsection <assoc-heap> }
+"Unique heaps:"
+{ $subsection <unique-min-heap> }
+{ $subsection <unique-max-heap> } ;
+
+ABOUT: "assoc-heaps"
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test assoc-heaps ;
+IN: assoc-heaps.tests
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs hashtables heaps kernel ;
+IN: assoc-heaps
+
+TUPLE: assoc-heap assoc heap ;
+
+C: <assoc-heap> assoc-heap
+
+: <unique-min-heap> ( -- unique-heap )
+ H{ } clone <min-heap> <assoc-heap> ;
+
+: <unique-max-heap> ( -- unique-heap )
+ H{ } clone <max-heap> <assoc-heap> ;
+
+M: assoc-heap heap-push* ( value key assoc-heap -- entry )
+ pick over assoc>> key? [
+ 3drop f
+ ] [
+ [ assoc>> swapd set-at ] [ heap>> heap-push* ] 3bi
+ ] if ;
+
+M: assoc-heap heap-pop ( assoc-heap -- value key )
+ heap>> heap-pop ;
+
+M: assoc-heap heap-peek ( assoc-heap -- value key )
+ heap>> heap-peek ;
+
+M: assoc-heap heap-empty? ( assoc-heap -- value key )
+ heap>> heap-empty? ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+Priority queue with fast insertion, removal of first element, and lookup of arbitrary elements by key
[ 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 ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test c.preprocessor kernel accessors multiline ;
+IN: c.preprocessor.tests
+
+[ "vocab:c/tests/test1/test1.c" start-preprocess-file ]
+[ include-nested-too-deeply? ] must-fail-with
+
+[ "yo\n\n\n\nyo4\n" ]
+[ "vocab:c/tests/test2/test2.c" start-preprocess-file nip ] unit-test
+
+/*
+[ "vocab:c/tests/test3/test3.c" start-preprocess-file ]
+[ "\"BOO\"" = ] must-fail-with
+*/
+
+[ V{ "\"omg\"" "\"lol\"" } ]
+[ "vocab:c/tests/test4/test4.c" start-preprocess-file drop warnings>> ] unit-test
+
+
+/*
+f(2 * (y+1)) + f(2 * (f(2 * (z[0])))) % f(2 * (0)) + t(1);
+f(2 * (2+(3,4)-0,1)) | f(2 * (~ 5)) & f(2 * (0,1))^m(0,1);
+int i[] = { 1, 23, 4, 5, };
+char c[2][6] = { "hello", "" };
+*/
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: html.parser.state io io.encodings.utf8 io.files
+io.streams.string kernel combinators accessors io.pathnames
+fry sequences arrays locals namespaces io.directories
+assocs math splitting make unicode.categories
+combinators.short-circuit ;
+IN: c.preprocessor
+
+: initial-library-paths ( -- seq )
+ V{ "/usr/include" } clone ;
+
+: initial-symbol-table ( -- hashtable )
+ H{
+ { "__APPLE__" "" }
+ { "__amd64__" "" }
+ { "__x86_64__" "" }
+ } clone ;
+
+TUPLE: preprocessor-state library-paths symbol-table
+include-nesting include-nesting-max processing-disabled?
+ifdef-nesting warnings errors
+pragmas
+include-nexts
+ifs elifs elses ;
+
+: <preprocessor-state> ( -- preprocessor-state )
+ preprocessor-state new
+ initial-library-paths >>library-paths
+ initial-symbol-table >>symbol-table
+ 0 >>include-nesting
+ 200 >>include-nesting-max
+ 0 >>ifdef-nesting
+ V{ } clone >>warnings
+ V{ } clone >>errors
+ V{ } clone >>pragmas
+ V{ } clone >>include-nexts
+ V{ } clone >>ifs
+ V{ } clone >>elifs
+ V{ } clone >>elses ;
+
+DEFER: preprocess-file
+
+ERROR: unknown-c-preprocessor state-parser name ;
+
+ERROR: bad-include-line line ;
+
+ERROR: header-file-missing path ;
+
+:: read-standard-include ( preprocessor-state path -- )
+ preprocessor-state dup library-paths>>
+ [ path append-path exists? ] find nip
+ [
+ dup [
+ path append-path
+ preprocess-file
+ ] with-directory
+ ] [
+ ! path header-file-missing
+ drop
+ ] if* ;
+
+:: read-local-include ( preprocessor-state path -- )
+ current-directory get path append-path dup :> full-path
+ dup exists? [
+ [ preprocessor-state ] dip preprocess-file
+ ] [
+ ! full-path header-file-missing
+ drop
+ ] if ;
+
+: handle-include ( preprocessor-state state-parser -- )
+ skip-whitespace advance dup previous {
+ { CHAR: < [ CHAR: > take-until-object read-standard-include ] }
+ { CHAR: " [ CHAR: " take-until-object read-local-include ] }
+ [ bad-include-line ]
+ } case ;
+
+: (readlns) ( -- )
+ readln "\\" ?tail [ , ] dip [ (readlns) ] when ;
+
+: readlns ( -- string ) [ (readlns) ] { } make concat ;
+
+: take-define-identifier ( state-parser -- string )
+ skip-whitespace
+ [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ;
+
+: handle-define ( preprocessor-state state-parser -- )
+ [ take-define-identifier ]
+ [ skip-whitespace take-rest ] bi
+ "\\" ?tail [ readlns append ] when
+ spin symbol-table>> set-at ;
+
+: handle-undef ( preprocessor-state state-parser -- )
+ take-token swap symbol-table>> delete-at ;
+
+: handle-ifdef ( preprocessor-state state-parser -- )
+ [ [ 1 + ] change-ifdef-nesting ] dip
+ take-token over symbol-table>> key?
+ [ drop ] [ t >>processing-disabled? drop ] if ;
+
+: handle-ifndef ( preprocessor-state state-parser -- )
+ [ [ 1 + ] change-ifdef-nesting ] dip
+ take-token over symbol-table>> key?
+ [ t >>processing-disabled? drop ]
+ [ drop ] if ;
+
+: handle-endif ( preprocessor-state state-parser -- )
+ drop [ 1 - ] change-ifdef-nesting drop ;
+
+: handle-if ( preprocessor-state state-parser -- )
+ [ [ 1 + ] change-ifdef-nesting ] dip
+ skip-whitespace take-rest swap ifs>> push ;
+
+: handle-elif ( preprocessor-state state-parser -- )
+ skip-whitespace take-rest swap elifs>> push ;
+
+: handle-else ( preprocessor-state state-parser -- )
+ skip-whitespace take-rest swap elses>> push ;
+
+: handle-pragma ( preprocessor-state state-parser -- )
+ skip-whitespace take-rest swap pragmas>> push ;
+
+: handle-include-next ( preprocessor-state state-parser -- )
+ skip-whitespace take-rest swap include-nexts>> push ;
+
+: handle-error ( preprocessor-state state-parser -- )
+ skip-whitespace take-rest swap errors>> push ;
+ ! nip take-rest throw ;
+
+: handle-warning ( preprocessor-state state-parser -- )
+ skip-whitespace
+ take-rest swap warnings>> push ;
+
+: parse-directive ( preprocessor-state state-parser string -- )
+ {
+ { "warning" [ handle-warning ] }
+ { "error" [ handle-error ] }
+ { "include" [ handle-include ] }
+ { "define" [ handle-define ] }
+ { "undef" [ handle-undef ] }
+ { "ifdef" [ handle-ifdef ] }
+ { "ifndef" [ handle-ifndef ] }
+ { "endif" [ handle-endif ] }
+ { "if" [ handle-if ] }
+ { "elif" [ handle-elif ] }
+ { "else" [ handle-else ] }
+ { "pragma" [ handle-pragma ] }
+ { "include_next" [ handle-include-next ] }
+ [ unknown-c-preprocessor ]
+ } case ;
+
+: parse-directive-line ( preprocessor-state state-parser -- )
+ advance dup take-token
+ pick processing-disabled?>> [
+ "endif" = [
+ drop f >>processing-disabled?
+ [ 1 - ] change-ifdef-nesting
+ drop
+ ] [ 2drop ] if
+ ] [
+ parse-directive
+ ] if ;
+
+: preprocess-line ( preprocessor-state state-parser -- )
+ skip-whitespace dup current CHAR: # =
+ [ parse-directive-line ]
+ [ swap processing-disabled?>> [ drop ] [ write-full nl ] if ] if ;
+
+: preprocess-lines ( preprocessor-state -- )
+ readln
+ [ <state-parser> [ preprocess-line ] [ drop preprocess-lines ] 2bi ]
+ [ drop ] if* ;
+
+ERROR: include-nested-too-deeply ;
+
+: check-nesting ( preprocessor-state -- preprocessor-state )
+ [ 1 + ] change-include-nesting
+ dup [ include-nesting>> ] [ include-nesting-max>> ] bi > [
+ include-nested-too-deeply
+ ] when ;
+
+: preprocess-file ( preprocessor-state path -- )
+ [ check-nesting ] dip
+ [ utf8 [ preprocess-lines ] with-file-reader ]
+ [ drop [ 1 - ] change-include-nesting drop ] 2bi ;
+
+: start-preprocess-file ( path -- preprocessor-state string )
+ dup parent-directory [
+ [
+ [ <preprocessor-state> dup ] dip preprocess-file
+ ] with-string-writer
+ ] with-directory ;
--- /dev/null
+Tests if the preprocessor bails on an infinite loop caused by mutually recursive #include lines.
--- /dev/null
+#include "lo.h"
--- /dev/null
+#include "hi.h"
--- /dev/null
+#include "hi.h"
--- /dev/null
+/*
+# lol
+*/
--- /dev/null
+#define FOO_H "foo.h"
+#include FOO_H
--- /dev/null
+#if 4 > (5 - 4++)
+#error "Umm"
+#endif
--- /dev/null
+#if 10
+#error "Umm"
--- /dev/null
+#if 4 > (1 + 2)
+good
+#endif
+
+#if 4 > 1 + 2
+good
+#endif
+
+#if (4 > 1) - 1
+bad
+#endif
+
+#if (4 > 1) - 2
+good
+#endif
--- /dev/null
+Tests whether #define and #ifdef/#endif work in the positive case.
--- /dev/null
+#define YO
+#ifdef YO
+yo
+#endif
+
+#define YO2
+#ifndef YO2
+yo2
+#endif
+
+#ifdef YO3
+yo3
+#endif
+
+#ifndef YO4
+yo4
+#endif
--- /dev/null
+Tests whether #define and #ifdef/#endif work in the positive case.
--- /dev/null
+#error "BOO"
--- /dev/null
+#warning "omg"
+#warning "lol"
--- /dev/null
+#define TABSIZE 100
+
+int table[TABSIZE];
--- /dev/null
+#define max(a, b) ((a) > (b) ? (a) : (b))
--- /dev/null
+#define x 3
+#define f(a) f(x * (a))
+#undef x
+#define x 2
+#define g f
+#define z z[0]
+#define h g(~
+#define m(a) a(w)
+#define w 0,1
+#define t(a) a
+#define p() int
+#define q(x) x
+#define r(x,y) x ## y
+#define str(x) # x
+f(y+1) + f(f(z)) % t(t(g)(0) + t)(1);
+g(x+(3,4)-w) | h 5) & m
+(f)^m(m);
+p() i[q()] = { q(1), r(2,3), r(4,), r(,5), r(,) };
+char c[2][6] = { str(hello), str() };
--- /dev/null
+#define str(s) #s
+#define xstr(s) str(s)
+#define debug(s, t) printf("x" # s "= %d, x" # t "= %s", \
+x ## s, x ## t)
+#define INCFILE(n) vers ## n
+#define glue(a, b) a## b
+#define xglue(a, b) glue(a, b)
+#define HIGHLOW "hello"
+#define LOW LOW ", world"
+debug(1, 2);
+fputs(str(strncmp("abc\0d", "abc", '\4') //this goes away
+== 0) str(: @\n), s);
+#include xstr(INCFILE(2).h)
+glue(HIGH, LOW);
+xglue(HIGH, LOW)
--- /dev/null
+#define t(x,y,z) x ## y ## z
+int j[] = { t(1,2,3), t(,4,5), t(6,,7), t(8,9,),
+t(10,,), t(,11,), t(,,12), t(,,) };
+
--- /dev/null
+USING: tools.deploy.config ;
+V{
+ { deploy-ui? t }
+ { deploy-io 1 }
+ { deploy-reflection 1 }
+ { deploy-compiler? t }
+ { deploy-math? t }
+ { deploy-word-props? f }
+ { deploy-c-types? f }
+ { "stop-after-last-window?" t }
+ { deploy-name "Chicago Talk" }
+}
--- /dev/null
+Slides for a talk at the Pycon VM Summit, Chicago, IL, March 2009
USING: tools.deploy.config ;
-V{
- { deploy-ui? t }
- { deploy-io 1 }
- { deploy-reflection 1 }
- { deploy-compiler? t }
- { deploy-math? t }
+H{
+ { deploy-name "Color Picker" }
{ deploy-word-props? f }
+ { deploy-ui? t }
+ { deploy-threads? t }
+ { deploy-unicode? f }
{ deploy-c-types? f }
+ { deploy-word-defs? f }
+ { deploy-compiler? t }
+ { deploy-io 2 }
+ { deploy-reflection 1 }
{ "stop-after-last-window?" t }
- { deploy-name "Color Picker" }
+ { deploy-math? t }
}
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors combinators.smart sorting.human
-models colors.constants present
+models colors.constants present sorting.slots
ui ui.gadgets.tables ui.gadgets.scrollers ;
IN: color-table
drop named-color ;
: <color-table> ( -- table )
- named-colors human-sort <model>
+ named-colors { human<=> } sort-by <model>
color-renderer
<table>
5 >>gap
: color-table-demo ( -- )
[ <color-table> <scroller> "Colors" open-window ] with-ui ;
-MAIN: color-table-demo
\ No newline at end of file
+MAIN: color-table-demo
-
-USING: kernel fry sequences
- vocabs.loader help.vocabs
- ui ui.gadgets ui.gadgets.buttons ui.gadgets.packs ui.gadgets.scrollers
- ui.tools.listener
- accessors ;
-
+USING: kernel fry sequences vocabs.loader help.vocabs ui
+ui.gadgets ui.gadgets.buttons ui.gadgets.packs ui.gadgets.borders
+ui.gadgets.scrollers ui.tools.listener accessors ;
IN: demos
: demo-vocabs ( -- seq ) "demos" tagged [ second ] map concat [ name>> ] map ;
: <run-vocab-button> ( vocab-name -- button )
- dup '[ drop [ _ run ] call-listener ] <border-button> ;
+ dup '[ drop [ _ run ] \ run call-listener ] <border-button> ;
: <demo-runner> ( -- gadget )
- <pile> 1 >>fill demo-vocabs [ <run-vocab-button> add-gadget ] each ;
-
-: demos ( -- ) [ <demo-runner> <scroller> "Demos" open-window ] with-ui ;
+ <pile> 1 >>fill { 2 2 } >>gap demo-vocabs [ <run-vocab-button> add-gadget ] each ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: demos ( -- ) [ <demo-runner> { 2 2 } <border> <scroller> "Demos" open-window ] with-ui ;
MAIN: demos
\ No newline at end of file
USING: words kernel sequences locals locals.parser
locals.definitions accessors parser namespaces continuations
-summary definitions generalizations arrays ;
+summary definitions generalizations arrays prettyprint debugger io ;
IN: descriptive
ERROR: descriptive-error args underlying word ;
-M: descriptive-error summary
- word>> "The " swap name>> " word encountered an error."
- 3append ;
+M: descriptive-error error.
+ "The word " write dup word>> pprint " encountered an error." print
+ "Arguments:" print
+ dup args>> stack.
+ "Error:" print
+ underlying>> error. ;
<PRIVATE
USING: assocs html.parser kernel math sequences strings ascii
arrays generalizations shuffle unicode.case namespaces make
splitting http accessors io combinators http.client urls
-urls.encoding fry prettyprint ;
+urls.encoding fry prettyprint sets ;
IN: html.parser.analyzer
TUPLE: link attributes clickable ;
[ [
[ name>> "a" = ]
[ attributes>> "href" swap key? ] bi and ] filter
- ] map sift [ [ attributes>> "href" swap at ] map ] map concat ;
+ ] map sift
+ [ [ attributes>> "href" swap at ] map ] map concat
+ [ >url ] map ;
+
+: find-frame-links ( vector -- vector' )
+ [ name>> "frame" = ] find-between-all
+ [ [ attributes>> "src" swap at ] map sift ] map concat sift
+ [ >url ] map ;
+
+: find-all-links ( vector -- vector' )
+ [ find-hrefs ] [ find-frame-links ] bi append prune ;
: find-forms ( vector -- vector' )
"form" over find-opening-tags-by-name
}
] [ "<a href = \"http://factorcode.org/\" foo = bar baz='quux'a=pirsqd >" parse-html ] unit-test
+[
+V{
+ T{ tag f "a"
+ H{
+ { "a" "pirsqd" }
+ { "foo" "bar" }
+ { "href" "http://factorcode.org/" }
+ { "baz" "quux" }
+ { "nofollow" "nofollow" }
+ } f f }
+}
+] [ "<a href = \"http://factorcode.org/\" nofollow foo = bar baz='quux'a=pirsqd >" parse-html ] unit-test
+
[
V{
T{ tag f "html" H{ } f f }
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays html.parser.utils hashtables io kernel
-namespaces make prettyprint quotations sequences splitting
-html.parser.state strings unicode.categories unicode.case ;
+USING: accessors arrays hashtables html.parser.state
+html.parser.utils kernel namespaces sequences
+unicode.case unicode.categories combinators.short-circuit
+quoting fry ;
IN: html.parser
TUPLE: tag name attributes text closing? ;
SINGLETON: text
SINGLETON: dtd
SINGLETON: comment
+
+<PRIVATE
+
SYMBOL: tagstack
: push-tag ( tag -- )
: closing-tag? ( string -- ? )
[ f ]
- [ [ first ] [ peek ] bi [ CHAR: / = ] bi@ or ] if-empty ;
+ [ { [ first CHAR: / = ] [ peek CHAR: / = ] } 1|| ] if-empty ;
: <tag> ( name attributes closing? -- tag )
tag new
: make-tag ( string attribs -- tag )
[ [ closing-tag? ] keep "/" trim1 ] dip rot <tag> ;
-: make-text-tag ( string -- tag )
+: new-tag ( text name -- tag )
tag new
- text >>name
- swap >>text ;
+ swap >>name
+ swap >>text ; inline
-: make-comment-tag ( string -- tag )
- tag new
- comment >>name
- swap >>text ;
+: (read-quote) ( state-parser ch -- string )
+ '[ [ current _ = ] take-until ] [ advance drop ] bi ;
-: make-dtd-tag ( string -- tag )
- tag new
- dtd >>name
- swap >>text ;
+: read-single-quote ( state-parser -- string )
+ CHAR: ' (read-quote) ;
-: read-whitespace ( -- string )
- [ get-char blank? not ] take-until ;
+: read-double-quote ( state-parser -- string )
+ CHAR: " (read-quote) ;
-: read-whitespace* ( -- ) read-whitespace drop ;
+: read-quote ( state-parser -- string )
+ dup get+increment CHAR: ' =
+ [ read-single-quote ] [ read-double-quote ] if ;
-: read-token ( -- string )
- read-whitespace*
- [ get-char blank? ] take-until ;
+: read-key ( state-parser -- string )
+ skip-whitespace
+ [ current { [ CHAR: = = ] [ blank? ] } 1|| ] take-until ;
-: read-single-quote ( -- string )
- [ get-char CHAR: ' = ] take-until ;
+: read-token ( state-parser -- string )
+ [ current blank? ] take-until ;
-: read-double-quote ( -- string )
- [ get-char CHAR: " = ] take-until ;
+: read-value ( state-parser -- string )
+ skip-whitespace
+ dup current quote? [ read-quote ] [ read-token ] if
+ [ blank? ] trim ;
-: read-quote ( -- string )
- get-char next CHAR: ' =
- [ read-single-quote ] [ read-double-quote ] if next ;
+: read-comment ( state-parser -- )
+ "-->" take-until-sequence comment new-tag push-tag ;
-: read-key ( -- string )
- read-whitespace*
- [ get-char [ CHAR: = = ] [ blank? ] bi or ] take-until ;
+: read-dtd ( state-parser -- )
+ ">" take-until-sequence dtd new-tag push-tag ;
-: read-= ( -- )
- read-whitespace*
- [ get-char CHAR: = = ] take-until drop next ;
+: read-bang ( state-parser -- )
+ advance dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&&
+ [ advance advance read-comment ] [ read-dtd ] if ;
-: read-value ( -- string )
- read-whitespace*
- get-char quote? [ read-quote ] [ read-token ] if
- [ blank? ] trim ;
+: read-tag ( state-parser -- string )
+ [ [ current "><" member? ] take-until ]
+ [ dup current CHAR: < = [ advance ] unless drop ] bi ;
-: read-comment ( -- )
- "-->" take-string make-comment-tag push-tag ;
+: read-until-< ( state-parser -- string )
+ [ current CHAR: < = ] take-until ;
-: read-dtd ( -- )
- ">" take-string make-dtd-tag push-tag ;
+: parse-text ( state-parser -- )
+ read-until-< [ text new-tag push-tag ] unless-empty ;
-: read-bang ( -- )
- next get-char CHAR: - = get-next CHAR: - = and [
- next next
- read-comment
- ] [
- read-dtd
- ] if ;
+: parse-key/value ( state-parser -- key value )
+ [ read-key >lower ]
+ [ skip-whitespace "=" take-sequence ]
+ [ swap [ read-value ] [ drop dup ] if ] tri ;
-: read-tag ( -- string )
- [ get-char CHAR: > = get-char CHAR: < = or ] take-until
- get-char CHAR: < = [ next ] unless ;
-
-: read-< ( -- string )
- next get-char CHAR: ! = [
- read-bang f
+: (parse-attributes) ( state-parser -- )
+ skip-whitespace
+ dup state-parse-end? [
+ drop
] [
- read-tag
+ [ parse-key/value swap set ] [ (parse-attributes) ] bi
] if ;
-: read-until-< ( -- string )
- [ get-char CHAR: < = ] take-until ;
+: parse-attributes ( state-parser -- hashtable )
+ [ (parse-attributes) ] H{ } make-assoc ;
-: parse-text ( -- )
- read-until-< [
- make-text-tag push-tag
- ] unless-empty ;
+: (parse-tag) ( string -- string' hashtable )
+ [
+ [ read-token >lower ] [ parse-attributes ] bi
+ ] state-parse ;
-: (parse-attributes) ( -- )
- read-whitespace*
- string-parse-end? [
- read-key >lower read-= read-value
- 2array , (parse-attributes)
- ] unless ;
+: read-< ( state-parser -- string/f )
+ advance dup current [
+ CHAR: ! = [ read-bang f ] [ read-tag ] if
+ ] [
+ drop f
+ ] if* ;
-: parse-attributes ( -- hashtable )
- [ (parse-attributes) ] { } make >hashtable ;
+: parse-tag ( state-parser -- )
+ read-< [ (parse-tag) make-tag push-tag ] unless-empty ;
-: (parse-tag) ( string -- string' hashtable )
- [
- read-token >lower
- parse-attributes
- ] string-parse ;
-
-: parse-tag ( -- )
- read-< [
- (parse-tag) make-tag push-tag
- ] unless-empty ;
-
-: (parse-html) ( -- )
- get-next [
- parse-text
- parse-tag
- (parse-html)
- ] when ;
+: (parse-html) ( state-parser -- )
+ dup peek-next [
+ [ parse-text ] [ parse-tag ] [ (parse-html) ] tri
+ ] [ drop ] if ;
: tag-parse ( quot -- vector )
- V{ } clone tagstack [ string-parse ] with-variable ; inline
+ V{ } clone tagstack [ state-parse ] with-variable ; inline
+
+PRIVATE>
: parse-html ( string -- vector )
[ (parse-html) tagstack get ] tag-parse ;
-USING: tools.test html.parser.state ascii kernel ;
+USING: tools.test html.parser.state ascii kernel accessors ;
IN: html.parser.state.tests
-: take-rest ( -- string )
- [ f ] take-until ;
+[ "hello" ]
+[ "hello" [ take-rest ] state-parse ] unit-test
-: take-char ( -- string )
- [ get-char = ] curry take-until ;
+[ "hi" " how are you?" ]
+[
+ "hi how are you?"
+ [ [ [ current blank? ] take-until ] [ take-rest ] bi ] state-parse
+] unit-test
+
+[ "foo" ";bar" ]
+[
+ "foo;bar" [
+ [ CHAR: ; take-until-object ] [ take-rest ] bi
+ ] state-parse
+] unit-test
-[ "hello" ] [ "hello" [ take-rest ] string-parse ] unit-test
-[ "hi" " how are you?" ] [ "hi how are you?" [ [ get-char blank? ] take-until take-rest ] string-parse ] unit-test
-[ "foo" ";bar" ] [ "foo;bar" [ CHAR: ; take-char take-rest ] string-parse ] unit-test
[ "foo " " bar" ]
-[ "foo and bar" [ "and" take-string take-rest ] string-parse ] unit-test
+[
+ "foo and bar" [
+ [ "and" take-until-sequence ] [ take-rest ] bi
+ ] state-parse
+] unit-test
+
+[ 6 ]
+[
+ " foo " [ skip-whitespace n>> ] state-parse
+] unit-test
+
+[ { 1 2 } ]
+[ { 1 2 3 } <state-parser> [ current 3 = ] take-until ] unit-test
+
+[ { 1 2 } ]
+[ { 1 2 3 4 } <state-parser> { 3 4 } take-until-sequence ] unit-test
+
+[ "ab" ]
+[ "abcd" <state-parser> "ab" take-sequence ] unit-test
+
+[ f ]
+[ "abcd" <state-parser> "lol" take-sequence ] unit-test
+
+[ "ab" ]
+[
+ "abcd" <state-parser>
+ [ "lol" take-sequence drop ] [ "ab" take-sequence ] bi
+] unit-test
+
+[ "" ]
+[ "abcd" <state-parser> "" take-sequence ] unit-test
+
+[ "cd" ]
+[ "abcd" <state-parser> [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test
+
+[ f ]
+[
+ "\"abc\" asdf" <state-parser>
+ [ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi
+] unit-test
+
+[ "abc\\\"def" ]
+[
+ "\"abc\\\"def\" asdf" <state-parser>
+ CHAR: \ CHAR: " take-quoted-string
+] unit-test
+
+[ "asdf" ]
+[
+ "\"abc\" asdf" <state-parser>
+ [ CHAR: \ CHAR: " take-quoted-string drop ]
+ [ skip-whitespace "asdf" take-sequence ] bi
+] unit-test
+
+[ f ]
+[
+ "\"abc asdf" <state-parser>
+ CHAR: \ CHAR: " take-quoted-string
+] unit-test
+
+[ "\"abc" ]
+[
+ "\"abc asdf" <state-parser>
+ [ CHAR: \ CHAR: " take-quoted-string drop ]
+ [ "\"abc" take-sequence ] bi
+] unit-test
+
+[ "c" ]
+[ "c" <state-parser> take-token ] unit-test
+
+[ f ]
+[ "" <state-parser> take-token ] unit-test
+
+[ "abcd e \\\"f g" ]
+[ "\"abcd e \\\"f g\"" <state-parser> CHAR: \ CHAR: " take-token* ] unit-test
+
+[ "" ]
+[ "" <state-parser> take-rest ] unit-test
+
+[ "" ]
+[ "abc" <state-parser> dup "abc" take-sequence drop take-rest ] unit-test
+
+[ f ]
+[ "abc" <state-parser> "abcdefg" take-sequence ] unit-test
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces math kernel sequences accessors fry circular ;
+USING: namespaces math kernel sequences accessors fry circular
+unicode.case unicode.categories locals combinators.short-circuit
+make combinators io splitting ;
+
IN: html.parser.state
-TUPLE: state string i ;
+TUPLE: state-parser sequence n ;
+
+: <state-parser> ( sequence -- state-parser )
+ state-parser new
+ swap >>sequence
+ 0 >>n ;
+
+: offset ( state-parser offset -- char/f )
+ swap
+ [ n>> + ] [ sequence>> ?nth ] bi ; inline
+
+: current ( state-parser -- char/f ) 0 offset ; inline
+
+: previous ( state-parser -- char/f ) -1 offset ; inline
+
+: peek-next ( state-parser -- char/f ) 1 offset ; inline
+
+: advance ( state-parser -- state-parser )
+ [ 1 + ] change-n ; inline
+
+: advance* ( state-parser -- )
+ advance drop ; inline
+
+: get+increment ( state-parser -- char/f )
+ [ current ] [ advance drop ] bi ; inline
+
+:: skip-until ( state-parser quot: ( obj -- ? ) -- )
+ state-parser current [
+ state-parser quot call [ state-parser advance quot skip-until ] unless
+ ] when ; inline recursive
+
+: state-parse-end? ( state-parser -- ? ) current not ;
+
+: take-until ( state-parser quot: ( obj -- ? ) -- sequence/f )
+ over state-parse-end? [
+ 2drop f
+ ] [
+ [ drop n>> ]
+ [ skip-until ]
+ [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq
+ ] if ; inline
+
+: take-while ( state-parser quot: ( obj -- ? ) -- sequence/f )
+ [ not ] compose take-until ; inline
+
+: <safe-slice> ( from to seq -- slice/f )
+ 3dup {
+ [ 2drop 0 < ]
+ [ [ drop ] 2dip length > ]
+ [ drop > ]
+ } 3|| [ 3drop f ] [ slice boa ] if ; inline
+
+:: take-sequence ( state-parser sequence -- obj/f )
+ state-parser [ n>> dup sequence length + ] [ sequence>> ] bi
+ <safe-slice> sequence sequence= [
+ sequence
+ state-parser [ sequence length + ] change-n drop
+ ] [
+ f
+ ] if ;
-: get-i ( -- i ) state get i>> ; inline
+:: take-until-sequence ( state-parser sequence -- sequence' )
+ sequence length <growing-circular> :> growing
+ state-parser
+ [
+ current growing push-growing-circular
+ sequence growing sequence=
+ ] take-until :> found
+ found dup length
+ growing length 1- - head
+ state-parser advance drop ;
+
+: skip-whitespace ( state-parser -- state-parser )
+ [ [ current blank? not ] take-until drop ] keep ;
-: get-char ( -- char )
- state get [ i>> ] [ string>> ] bi ?nth ; inline
+: take-rest-slice ( state-parser -- sequence/f )
+ [ sequence>> ] [ n>> ] bi
+ 2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
-: get-next ( -- char )
- state get [ i>> 1+ ] [ string>> ] bi ?nth ; inline
+: take-rest ( state-parser -- sequence )
+ [ take-rest-slice ] [ sequence>> like ] bi ;
-: next ( -- )
- state get [ 1+ ] change-i drop ; inline
+: take-until-object ( state-parser obj -- sequence )
+ '[ current _ = ] take-until ;
-: string-parse ( string quot -- )
- [ 0 state boa state ] dip with-variable ; inline
+: state-parse ( sequence quot -- )
+ [ <state-parser> ] dip call ; inline
-: short* ( n seq -- n' seq )
- over [ nip dup length swap ] unless ; inline
+:: take-quoted-string ( state-parser escape-char quote-char -- string )
+ state-parser n>> :> start-n
+ state-parser advance
+ [
+ {
+ [ { [ previous escape-char = ] [ current quote-char = ] } 1&& ]
+ [ current quote-char = not ]
+ } 1||
+ ] take-while :> string
+ state-parser current quote-char = [
+ state-parser advance* string
+ ] [
+ start-n state-parser (>>n) f
+ ] if ;
-: skip-until ( quot: ( -- ? ) -- )
- get-char [
- [ call ] keep swap
- [ drop ] [ next skip-until ] if
- ] [ drop ] if ; inline recursive
+: (take-token) ( state-parser -- string )
+ skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ;
-: take-until ( quot: ( -- ? ) -- )
- get-i [ skip-until ] dip get-i
- state get string>> subseq ; inline
+:: take-token* ( state-parser escape-char quote-char -- string/f )
+ state-parser skip-whitespace
+ dup current {
+ { quote-char [ escape-char quote-char take-quoted-string ] }
+ { f [ drop f ] }
+ [ drop (take-token) ]
+ } case ;
-: string-matches? ( string circular -- ? )
- get-char over push-growing-circular sequence= ; inline
+: take-token ( state-parser -- string/f )
+ CHAR: \ CHAR: " take-token* ;
-: take-string ( match -- string )
- dup length <growing-circular>
- [ 2dup string-matches? ] take-until nip
- dup length rot length 1- - head next ; inline
+: write-full ( state-parser -- ) sequence>> write ;
+: write-rest ( state-parser -- ) take-rest write ;
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
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 ;
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 ;
" 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
boot-cmd
] with-scope
] unit-test
+
+[ { "./factor.com" "-i=boot.x86.32.image" "-no-user-init" } ] [
+ [
+ "winnt" target-os set
+ "x86.32" target-cpu set
+ boot-cmd
+ ] with-scope
+] unit-test
! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays calendar combinators.short-circuit
-continuations debugger http.client io.directories io.files io.launcher
+continuations debugger io.directories io.files io.launcher
io.pathnames io.encodings.ascii kernel make mason.common mason.config
mason.platform mason.report mason.email namespaces sequences ;
IN: mason.child
: make-cmd ( -- args )
gnu-make platform 2array ;
-: dll-url ( -- url )
- "http://factorcode.org/dlls/"
- target-cpu get "x86.64" = [ "64/" append ] when ;
-
-: download-dlls ( -- )
- target-os get "winnt" = [
- dll-url "build-support/dlls.txt" ascii file-lines
- [ append download ] with each
- ] when ;
-
: make-vm ( -- )
"factor" [
- download-dlls
-
<process>
make-cmd >>command
"../compile-log" >>stdout
builds-factor-image "." copy-file-into
builds-factor-image "factor" copy-file-into ;
+: factor-vm ( -- string )
+ target-os get "winnt" = "./factor.com" "./factor" ? ;
+
: boot-cmd ( -- cmd )
- "./factor"
+ factor-vm
"-i=" boot-image-name append
"-no-user-init"
3array ;
try-process
] with-directory ;
-: test-cmd ( -- cmd ) { "./factor" "-run=mason.test" } ;
+: test-cmd ( -- cmd ) factor-vm "-run=mason.test" 2array ;
: test ( -- )
"factor" [
{ deploy-word-props? f }
{ deploy-c-types? f }
{ "stop-after-last-window?" t }
- { deploy-name "Catalyst Talk" }
+ { deploy-name "Minnesota Talk" }
}
-Slides for a talk at Ruby.mn, Minneapolis MN, January 2008
+Slides for a talk at Ruby.mn, Minneapolis, MN, January 2008
#! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0
-EBNF: pl0
+EBNF: pl0
-block = { "CONST" ident "=" number { "," ident "=" number }* ";" }?
- { "VAR" ident { "," ident }* ";" }?
- { "PROCEDURE" ident ";" { block ";" }? }* statement
-statement = { ident ":=" expression
- | "CALL" ident
- | "BEGIN" statement { ";" statement }* "END"
- | "IF" condition "THEN" statement
- | "WHILE" condition "DO" statement }?
+block = { "CONST" ident "=" number { "," ident "=" number }* ";" }?
+ { "VAR" ident { "," ident }* ";" }?
+ { "PROCEDURE" ident ";" { block ";" }? }* statement
+statement = { ident ":=" expression
+ | "CALL" ident
+ | "BEGIN" statement { ";" statement }* "END"
+ | "IF" condition "THEN" statement
+ | "WHILE" condition "DO" statement }?
condition = { "ODD" expression }
| { expression ("=" | "#" | "<=" | "<" | ">=" | ">") expression }
-expression = {"+" | "-"}? term { {"+" | "-"} term }*
-term = factor { {"*" | "/"} factor }*
+expression = {"+" | "-"}? term { {"+" | "-"} term }*
+term = factor { {"*" | "/"} factor }*
factor = ident | number | "(" expression ")"
ident = (([a-zA-Z])+) => [[ >string ]]
digit = ([0-9]) => [[ digit> ]]
[ 233168 ] [ euler001 ] unit-test
[ 233168 ] [ euler001a ] unit-test
[ 233168 ] [ euler001b ] unit-test
+[ 233168 ] [ euler001c ] unit-test
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007, 2008 Aaron Schaefer, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.ranges sequences project-euler.common ;
+USING: kernel math math.functions math.ranges sequences project-euler.common ;
IN: project-euler.001
! http://projecteuler.net/index.php?section=problems&id=1
! [ euler001b ] 100 ave-time
! 0 ms run / 0 ms GC ave time - 100 trials
+
+: euler001c ( -- answer )
+ 1000 [ { 3 5 } [ divisor? ] with any? ] filter sum ;
+
+! [ euler001c ] 100 ave-time
+! 0 ms ave run time - 0.06 SD (100 trials)
+
SOLUTION: euler001
! Copyright (c) 2007 Aaron Schaefer, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: hashtables kernel math math.ranges project-euler.common sequences
- sorting sets ;
+USING: hashtables kernel math math.functions math.ranges project-euler.common
+ sequences sorting sets ;
IN: project-euler.004
! http://projecteuler.net/index.php?section=problems&id=4
<PRIVATE
: source-004 ( -- seq )
- 100 999 [a,b] [ 10 mod 0 = not ] filter ;
+ 100 999 [a,b] [ 10 divisor? not ] filter ;
: max-palindrome ( seq -- palindrome )
natural-sort [ palindrome? ] find-last nip ;
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit kernel make math math.ranges
-sequences project-euler.common ;
+USING: combinators.short-circuit kernel make math math.functions math.ranges
+ sequences project-euler.common ;
IN: project-euler.014
! http://projecteuler.net/index.php?section=problems&id=14
<PRIVATE
: worth-calculating? ( n -- ? )
- 1- 3 { [ mod 0 = ] [ / even? ] } 2&& ;
+ 1- 3 { [ divisor? ] [ / even? ] } 2&& ;
PRIVATE>
10 99 [a,b] dup cartesian-product [ first2 < ] filter ;
: safe? ( ax xb -- ? )
- [ 10 /mod ] bi@ -roll = rot zero? not and nip ;
+ [ 10 /mod ] bi@ [ = ] dip zero? not and nip ;
: ax/xb ( ax xb -- z/f )
2dup safe? [ [ 10 /mod ] bi@ 2nip / ] [ 2drop f ] if ;
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit kernel math math.combinatorics math.parser
- math.ranges project-euler.common sequences sets sorting ;
+USING: combinators.short-circuit kernel math math.functions math.combinatorics
+ math.parser math.ranges project-euler.common sequences sets sorting ;
IN: project-euler.043
! http://projecteuler.net/index.php?section=problems&id=43
<PRIVATE
: subseq-divisible? ( n index seq -- ? )
- [ 1- dup 3 + ] dip subseq 10 digits>integer swap mod zero? ;
+ [ 1- dup 3 + ] dip subseq 10 digits>integer swap divisor? ;
: interesting? ( seq -- ? )
{
--- /dev/null
+USING: project-euler.049 tools.test ;
+IN: project-euler.049.tests
+
+[ 296962999629 ] [ euler049 ] unit-test
--- /dev/null
+! Copyright (c) 2009 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays byte-arrays fry hints kernel math math.combinatorics
+ math.functions math.parser math.primes project-euler.common sequences sets ;
+IN: project-euler.049
+
+! http://projecteuler.net/index.php?section=problems&id=49
+
+! DESCRIPTION
+! -----------
+
+! The arithmetic sequence, 1487, 4817, 8147, in which each of the terms
+! increases by 3330, is unusual in two ways: (i) each of the three terms are
+! prime, and, (ii) each of the 4-digit numbers are permutations of one another.
+
+! There are no arithmetic sequences made up of three 1-, 2-, or 3-digit primes,
+! exhibiting this property, but there is one other 4-digit increasing sequence.
+
+! What 12-digit number do you form by concatenating the three terms in this
+! sequence?
+
+
+! SOLUTION
+! --------
+
+<PRIVATE
+
+: count-digits ( n -- byte-array )
+ 10 <byte-array> [
+ '[ 10 /mod _ [ 1+ ] change-nth dup 0 > ] loop drop
+ ] keep ;
+
+HINTS: count-digits fixnum ;
+
+: permutations? ( n m -- ? )
+ [ count-digits ] bi@ = ;
+
+: collect-permutations ( seq -- seq )
+ [ V{ } clone ] [ dup ] bi* [
+ dupd '[ _ permutations? ] filter
+ [ diff ] keep pick push
+ ] each drop ;
+
+: potential-sequences ( -- seq )
+ 1000 9999 primes-between
+ collect-permutations [ length 3 >= ] filter ;
+
+: arithmetic-terms ( m n -- seq )
+ 2dup [ swap - ] keep + 3array ;
+
+: (find-unusual-terms) ( n seq -- seq/f )
+ [ [ arithmetic-terms ] with map ] keep
+ '[ _ [ peek ] dip member? ] find nip ;
+
+: find-unusual-terms ( seq -- seq/? )
+ unclip-slice over (find-unusual-terms) [
+ nip
+ ] [
+ dup length 3 >= [ find-unusual-terms ] [ drop f ] if
+ ] if* ;
+
+: 4digit-concat ( seq -- str )
+ 0 [ [ 10000 * ] dip + ] reduce ;
+
+PRIVATE>
+
+: euler049 ( -- answer )
+ potential-sequences [ find-unusual-terms ] map sift
+ [ { 1487 4817 8147 } = not ] find nip 4digit-concat ;
+
+! [ euler049 ] 100 ave-time
+! 206 ms ave run time - 10.25 SD (100 trials)
+
+SOLUTION: euler049
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit kernel math
- project-euler.common sequences sorting
- grouping ;
+USING: combinators.short-circuit kernel math math.functions
+ project-euler.common sequences sorting grouping ;
IN: project-euler.052
! http://projecteuler.net/index.php?section=problems&id=52
[ number>digits natural-sort ] map all-equal? ;
: candidate? ( n -- ? )
- { [ odd? ] [ 3 mod 0 = ] } 1&& ;
+ { [ odd? ] [ 3 divisor? ] } 1&& ;
: next-all-same ( x n -- n )
dup candidate? [
: (sum-divisors) ( n -- sum )
dup sqrt >integer [1,b] [
- [ 2dup mod 0 = [ 2dup / + , ] [ drop ] if ] each
+ [ 2dup divisor? [ 2dup / + , ] [ drop ] if ] each
dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if
] { } make sum ;
>lower [ CHAR: a - 1+ ] sigma ;
: cartesian-product ( seq1 seq2 -- seq1xseq2 )
- swap [ swap [ 2array ] with map ] with map concat ;
+ [ [ 2array ] with map ] curry map concat ;
: log10 ( m -- n )
log 10 log / ;
: number>digits ( n -- seq )
[ dup 0 = not ] [ 10 /mod ] produce reverse nip ;
+: number-length ( n -- m )
+ log10 floor 1+ >integer ;
+
: nth-triangle ( n -- n )
dup 1+ * 2 / ;
factor-2s dup [ 1+ ]
[ perfect-square? -1 0 ? ]
[ dup sqrt >fixnum [1,b] ] tri* [
- dupd mod 0 = [ [ 2 + ] dip ] when
+ dupd divisor? [ [ 2 + ] dip ] when
] each drop * ;
! These transforms are for generating primitive Pythagorean triples
[ drop in get vocab (>>main) ]
[ [ . ] swap prefix (( -- )) define-declared ]
2bi ;
-
project-euler.037 project-euler.038 project-euler.039 project-euler.040
project-euler.041 project-euler.042 project-euler.043 project-euler.044
project-euler.045 project-euler.046 project-euler.047 project-euler.048
- project-euler.052 project-euler.053 project-euler.055 project-euler.056
- project-euler.057 project-euler.059 project-euler.067 project-euler.071
- project-euler.073 project-euler.075 project-euler.076 project-euler.079
- project-euler.092 project-euler.097 project-euler.099 project-euler.100
- project-euler.116 project-euler.117 project-euler.134 project-euler.148
- project-euler.150 project-euler.151 project-euler.164 project-euler.169
- project-euler.173 project-euler.175 project-euler.186 project-euler.190
- project-euler.203 project-euler.215 ;
+ project-euler.049 project-euler.052 project-euler.053 project-euler.055
+ project-euler.056 project-euler.057 project-euler.059 project-euler.067
+ project-euler.071 project-euler.073 project-euler.075 project-euler.076
+ project-euler.079 project-euler.092 project-euler.097 project-euler.099
+ project-euler.100 project-euler.116 project-euler.117 project-euler.134
+ project-euler.148 project-euler.150 project-euler.151 project-euler.164
+ project-euler.169 project-euler.173 project-euler.175 project-euler.186
+ project-euler.190 project-euler.203 project-euler.215 ;
IN: project-euler
<PRIVATE
--- /dev/null
+! 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 ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces assocs accessors words sequences classes.tuple ;
+IN: smalltalk.classes
+
+SYMBOL: classes
+
+classes [ H{ } clone ] initialize
+
+: create-class ( class -- class )
+ "smalltalk.classes" create ;
+
+ERROR: no-class name ;
+
+: lookup-class ( class -- class )
+ classes get ?at [ ] [ no-class ] if ;
+
+: define-class ( class superclass ivars -- class-word )
+ [ create-class ] [ lookup-class ] [ ] tri*
+ [ define-tuple-class ] [ 2drop dup dup name>> classes get set-at ] 3bi ;
+
+: define-foreign ( class name -- )
+ classes get set-at ;
+
+tuple "Object" define-foreign
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel sequences sets smalltalk.ast ;
+IN: smalltalk.compiler.assignment
+
+GENERIC: assigned-locals ( ast -- seq )
+
+M: ast-return assigned-locals value>> assigned-locals ;
+
+M: ast-block assigned-locals
+ [ body>> assigned-locals ] [ arguments>> ] bi diff ;
+
+M: ast-message-send assigned-locals
+ [ receiver>> assigned-locals ]
+ [ arguments>> assigned-locals ]
+ bi append ;
+
+M: ast-cascade assigned-locals
+ [ receiver>> assigned-locals ]
+ [ messages>> assigned-locals ]
+ bi append ;
+
+M: ast-message assigned-locals
+ arguments>> assigned-locals ;
+
+M: ast-assignment assigned-locals
+ [ name>> dup ast-name? [ name>> 1array ] [ drop { } ] if ]
+ [ value>> assigned-locals ] bi append ;
+
+M: ast-sequence assigned-locals
+ body>> assigned-locals ;
+
+M: array assigned-locals
+ [ assigned-locals ] map concat ;
+
+M: object assigned-locals drop f ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+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
\ No newline at end of file
--- /dev/null
+! 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 ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+USING: smalltalk.compiler.lexenv tools.test kernel namespaces accessors ;
+IN: smalltalk.compiler.lexenv.tests
+
+TUPLE: some-class x y z ;
+
+SYMBOL: fake-self
+
+SYMBOL: fake-local
+
+<lexenv>
+ some-class >>class
+ fake-self >>self
+ H{ { "mumble" fake-local } } >>local-readers
+ H{ { "jumble" fake-local } } >>local-writers
+lexenv set
+
+[ [ fake-local ] ] [ "mumble" lexenv get lookup-reader ] unit-test
+[ [ fake-self x>> ] ] [ "x" lexenv get lookup-reader ] unit-test
+[ [ \ tuple ] ] [ "Object" lexenv get lookup-reader ] unit-test
+
+[ [ fake-local ] ] [ "jumble" lexenv get lookup-writer ] unit-test
+[ [ fake-self (>>y) ] ] [ "y" lexenv get lookup-writer ] unit-test
+
+[ "blahblah" lexenv get lookup-writer ] must-fail
\ No newline at end of file
--- /dev/null
+! 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|| ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+USING: smalltalk.parser smalltalk.compiler.return tools.test ;
+
+[ t ] [ "(i <= 1) ifTrue: [^1] ifFalse: [^((Fib new i:(i-1)) compute + (Fib new i:(i-2)) compute)]" parse-smalltalk need-return-continuation? ] unit-test
\ No newline at end of file
--- /dev/null
+! 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 ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+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
\ No newline at end of file
--- /dev/null
+! 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 ;
--- /dev/null
+class Fib [
+ |i|
+ method i: newI [i:=newI].
+ method compute [
+ (i <= 1)
+ ifTrue: [^1]
+ ifFalse: [^((Fib new i:(i-1)) compute + (Fib new i:(i-2)) compute)]
+ ].
+].
+
+[(Fib new i: 26) compute] time
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel 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 ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel 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
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+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
\ No newline at end of file
--- /dev/null
+! 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
\ No newline at end of file
--- /dev/null
+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
+ ]
+].
+
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+IN: smalltalk.printer.tests
+USING: smalltalk.printer tools.test ;
+
+[ "#((1 2) 'hi')" ] [ { { 1 2 } "hi" } smalltalk>string ] unit-test
\ No newline at end of file
--- /dev/null
+! 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 ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: 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 ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators kernel math
+math.statistics namespaces sequences sorting xml.syntax
+spider ;
+IN: spider.report
+
+SYMBOL: network-failures
+SYMBOL: broken-pages
+SYMBOL: timings
+
+: record-broken-page ( url spider-result -- )
+ headers>> [ code>> ] [ message>> ] bi 2array 2array
+ broken-pages push ;
+
+: record-page-timings ( url spider-result -- )
+ fetched-in>> 2array timings get push ;
+
+: record-network-failure ( url -- )
+ network-failures get push ;
+
+: process-result ( url spider-result -- )
+ {
+ { f [ record-network-failure ] }
+ [
+ dup headers>> code>> 200 =
+ [ record-page-timings ] [ record-broken-page ] if
+ ]
+ } case ;
+
+CONSTANT: slowest 5
+
+SYMBOL: slowest-pages
+SYMBOL: mean-time
+SYMBOL: median-time
+SYMBOL: time-std
+
+: process-timings ( -- )
+ timings get sort-values
+ [ slowest short tail* reverse slowest-pages set ]
+ [
+ values
+ [ mean 1000000 /f mean-time set ]
+ [ median 1000000 /f median-time set ]
+ [ std 1000000 /f time-std set ] tri
+ ] bi ;
+
+: process-results ( results -- )
+ V{ } clone network-failures set
+ V{ } clone broken-pages set
+ V{ } clone timings set
+ [ process-result ] assoc-each
+ process-timings ;
+
+: info-table ( alist -- html )
+ [
+ first2 dupd 1000000 /f
+ [XML
+ <tr><td><a href=<->><-></a></td><td><-> seconds</td></tr>
+ XML]
+ ] map [XML <table border="1"><-></table> XML] ;
+
+: report-broken-pages ( -- html )
+ broken-pages get info-table ;
+
+: report-network-failures ( -- html )
+ network-failures get [
+ dup [XML <li><a href=<->><-></a></li> XML]
+ ] map [XML <ul><-></ul> XML] ;
+
+: slowest-pages-table ( -- html )
+ slowest-pages get info-table ;
+
+: timing-summary-table ( -- html )
+ mean-time get
+ median-time get
+ time-std get
+ [XML
+ <table border="1">
+ <tr><th>Mean</th><td><-> seconds</td></tr>
+ <tr><th>Median</th><td><-> seconds</td></tr>
+ <tr><th>Standard deviation</th><td><-> seconds</td></tr>
+ </table>
+ XML] ;
+
+: report-timings ( -- html )
+ slowest-pages-table
+ timing-summary-table
+ [XML
+ <h2>Slowest pages</h2>
+ <->
+
+ <h2>Summary</h2>
+ <->
+ XML] ;
+
+: generate-report ( -- html )
+ report-broken-pages
+ report-network-failures
+ report-timings
+ [XML
+ <h1>Broken pages</h1>
+ <->
+
+ <h1>Network failures</h1>
+ <->
+
+ <h1>Load times</h1>
+ <->
+ XML] ;
+
+: spider-report ( spider -- html )
+ [ spidered>> process-results generate-report ] with-scope ;
{ "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> "> }
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
+spider.unique-deque ;
IN: spider
TUPLE: spider base count max-count sleep max-depth initial-links
-filters spidered todo nonmatching quiet ;
+filters spidered todo nonmatching quiet currently-spidering
+#threads follow-robots? robots ;
-TUPLE: spider-result url depth headers fetch-time parsed-html
-links processing-time timestamp ;
+TUPLE: spider-result url depth headers
+fetched-in parsed-html links processed-in fetched-at ;
: <spider> ( base -- spider )
>url
spider new
over >>base
- swap 0 <unique-min-heap> [ heap-push ] keep >>todo
- <unique-min-heap> >>nonmatching
+ over >>currently-spidering
+ swap 0 <unique-deque> [ push-url ] keep >>todo
+ <unique-deque> >>nonmatching
0 >>max-depth
0 >>count
1/0. >>max-count
- H{ } clone >>spidered ;
+ H{ } clone >>spidered
+ 1 >>#threads ;
<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 ;
: 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 ( base links -- links' )
+ [ 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 :> fetched-at :> html :> headers
+ [
+ html parse-html
+ spider currently-spidering>>
+ over find-all-links normalize-hrefs
+ ] benchmark :> processing-time :> links :> parsed-html
+ url depth headers fetched-at 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 -- )
+ [
+ [ currently-spidering>> ] [ initial-links>> ] bi normalize-hrefs 0
+ ] keep add-todo ;
-: slurp-heap-while ( heap quot1 quot2: ( value key -- ) -- )
- pick heap-empty? [ 3drop ] [
- [ [ heap-pop dup ] 2dip slip [ t ] compose [ 2drop f ] if ]
- [ roll [ slurp-heap-while ] [ 3drop ] if ] 3bi
- ] if ; inline recursive
+: spider-page? ( spider -- ? )
+ {
+ [ todo>> deque>> deque-empty? not ]
+ [ [ todo>> peek-url depth>> ] [ max-depth>> ] bi < ]
+ [ [ count>> ] [ max-count>> ] bi < ]
+ } 1&& ;
+
+: setup-next-url ( spider -- spider url depth )
+ dup todo>> peek-url url>> >>currently-spidering
+ dup todo>> pop-url [ url>> ] [ depth>> ] bi ;
+
+: spider-next-page ( spider -- )
+ setup-next-url spider-page ;
PRIVATE>
+: run-spider-loop ( spider -- )
+ dup spider-page? [
+ [ spider-next-page ] [ spider-sleep ] [ run-spider-loop ] tri
+ ] [
+ drop
+ ] if ;
+
: run-spider ( spider -- spider )
"spider" [
- dup spider [
- queue-initial-links
- [ todo>> ] [ max-depth>> ] bi
- '[
- _ <= spider get
- [ count>> ] [ max-count>> ] bi < and
- ] [ spider-page spider-sleep ] slurp-heap-while
- spider get
- ] with-variable
+ dup queue-initial-links [ run-spider-loop ] keep
] with-logging ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs deques dlists kernel spider ;
+IN: spider.unique-deque
+
+TUPLE: todo-url url depth ;
+
+: <todo-url> ( url depth -- todo-url )
+ todo-url new
+ swap >>depth
+ swap >>url ;
+
+TUPLE: unique-deque assoc deque ;
+
+: <unique-deque> ( -- unique-deque )
+ H{ } clone <dlist> unique-deque boa ;
+
+: url-exists? ( url unique-deque -- ? )
+ [ url>> ] [ assoc>> ] bi* key? ;
+
+: push-url ( url depth unique-deque -- )
+ [ <todo-url> ] dip 2dup url-exists? [
+ 2drop
+ ] [
+ [ [ [ t ] dip url>> ] [ assoc>> ] bi* set-at ]
+ [ deque>> push-back ] 2bi
+ ] if ;
+
+: pop-url ( unique-deque -- todo-url ) deque>> pop-front ;
+
+: peek-url ( unique-deque -- todo-url ) deque>> peek-front ;
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel quotations ui.gadgets
-images.bitmap strings ui.gadgets.worlds ;
+images strings ui.gadgets.worlds ;
IN: ui.offscreen
HELP: <offscreen-world>
HELP: gadget>bitmap
{ $values
{ "gadget" gadget }
- { "bitmap" bitmap }
+ { "image" image }
}
-{ $description "Renders " { $snippet "gadget" } " to an " { $link offscreen-world } " and creates a " { $link bitmap } " from its contents." } ;
+{ $description "Renders " { $snippet "gadget" } " to an " { $link offscreen-world } " and creates an " { $link image } " from its contents." } ;
HELP: offscreen-world
{ $class-description "The class of " { $link world } " objects that render to an offscreen buffer." } ;
HELP: offscreen-world>bitmap
{ $values
{ "world" offscreen-world }
- { "bitmap" bitmap }
+ { "image" image }
}
-{ $description "Saves a copy of the contents of " { $snippet "world" } " to a " { $link bitmap } " object." } ;
+{ $description "Saves a copy of the contents of " { $snippet "world" } " to a " { $link image } " object." } ;
HELP: open-offscreen
{ $values
! (c) 2008 Joe Groff, see license for details
-USING: accessors continuations images.bitmap kernel math
-sequences ui.gadgets ui.gadgets.worlds ui ui.backend
-destructors ;
+USING: accessors alien.c-types continuations images kernel math
+sequences ui.gadgets ui.gadgets.private ui.gadgets.worlds
+ui.private ui ui.backend destructors locals ;
IN: ui.offscreen
TUPLE: offscreen-world < world ;
: open-offscreen ( gadget -- world )
"" f <offscreen-world>
- [ open-world-window dup relayout-1 ] keep
+ [ open-world-window ] [ relayout-1 ] [ ] tri
notify-queued ;
: close-offscreen ( world -- )
ungraft notify-queued ;
-: offscreen-world>bitmap ( world -- bitmap )
- offscreen-pixels bgra>bitmap ;
+:: bgrx>bitmap ( alien w h -- image )
+ <image>
+ { w h } >>dim
+ alien w h * 4 * memory>byte-array >>bitmap
+ BGRX >>component-order ;
+
+: offscreen-world>bitmap ( world -- image )
+ offscreen-pixels bgrx>bitmap ;
: do-offscreen ( gadget quot: ( offscreen-world -- ) -- )
[ open-offscreen ] dip
over [ slip ] [ close-offscreen ] [ ] cleanup ; inline
-: gadget>bitmap ( gadget -- bitmap )
+: gadget>bitmap ( gadget -- image )
[ offscreen-world>bitmap ] do-offscreen ;
(number constant "integers and floats")
(ratio constant "ratios")
(declaration keyword "declaration words")
+ (ebnf-form constant "EBNF: ... ;EBNF form")
(parsing-word keyword "parsing words")
(setter-word function-name "setter words (>>foo)")
(getter-word function-name "getter words (foo>>)")
(defun fuel-font-lock--syntactic-face (state)
(if (nth 3 state) 'factor-font-lock-string
(let ((c (char-after (nth 8 state))))
- (cond ((or (char-equal c ?\ ) (char-equal c ?\n))
+ (cond ((or (char-equal c ?\ )
+ (char-equal c ?\n)
+ (char-equal c ?E))
(save-excursion
(goto-char (nth 8 state))
(beginning-of-line)
'factor-font-lock-symbol)
((looking-at-p "C-ENUM:\\( \\|\n\\)")
'factor-font-lock-constant)
+ ((looking-at-p "E")
+ 'factor-font-lock-ebnf-form)
(t 'default))))
((or (char-equal c ?U) (char-equal c ?C))
'factor-font-lock-parsing-word)
(let ((name (match-string-no-properties 2))
(body (match-string-no-properties 4))
(end (match-end 0)))
- (list (split-string body nil t) name pos end)))))
+ (list (split-string (or body "") nil t) name pos end)))))
(defun fuel-refactor--find (code to)
(let ((candidate) (result))
(defun fuel-refactor--insert-word (word stack-effect code)
(let ((start (goto-char (fuel-refactor--insertion-point))))
(open-line 1)
- (insert ": " word " " stack-effect "\n" code " ;\n")
+ (insert ": " word " " stack-effect "\n" (or code " ") " ;\n")
(indent-region start (point))
(move-overlay fuel-stack--overlay start (point))))
(delete-overlay fuel-stack--overlay)))
(defun fuel-refactor--extract (begin end)
- (unless (< begin end) (error "No proper region to extract"))
- (let* ((code (buffer-substring begin end))
- (existing (fuel-refactor--reuse-existing code))
- (code-str (or existing (fuel--region-to-string begin end)))
+ (let* ((rp (< begin end))
+ (code (and rp (buffer-substring begin end)))
+ (existing (and code (fuel-refactor--reuse-existing code)))
+ (code-str (and code (or existing (fuel--region-to-string begin end))))
(word (or (car existing) (read-string "New word name: ")))
(stack-effect (or existing
- (fuel-stack--infer-effect code-str)
+ (and code-str (fuel-stack--infer-effect code-str))
(read-string "Stack effect: "))))
- (goto-char begin)
- (delete-region begin end)
- (insert word)
- (indent-region begin (point))
+ (when rp
+ (goto-char begin)
+ (delete-region begin end)
+ (insert word)
+ (indent-region begin (point)))
(save-excursion
(let ((start (or (cadr existing) (point))))
(unless existing
(fuel-refactor--insert-word word stack-effect code))
- (fuel-refactor--extract-other start
- (or (car (cddr existing)) (point))
- code)))))
+ (if rp
+ (fuel-refactor--extract-other start
+ (or (car (cddr existing)) (point))
+ code)
+ (unwind-protect
+ (sit-for fuel-stack-highlight-period)
+ (delete-overlay fuel-stack--overlay)))))))
(defun fuel-refactor-extract-region (begin end)
"Extracts current region as a separate word."
(interactive "r")
- (let ((begin (save-excursion
- (goto-char begin)
- (when (zerop (skip-syntax-backward "w"))
- (skip-syntax-forward "-"))
- (point)))
- (end (save-excursion
- (goto-char end)
- (skip-syntax-forward "w")
- (point))))
- (fuel-refactor--extract begin end)))
+ (if (= begin end)
+ (fuel-refactor--extract begin end)
+ (let ((begin (save-excursion
+ (goto-char begin)
+ (when (zerop (skip-syntax-backward "w"))
+ (skip-syntax-forward "-"))
+ (point)))
+ (end (save-excursion
+ (goto-char end)
+ (skip-syntax-forward "w")
+ (point))))
+ (fuel-refactor--extract begin end))))
(defun fuel-refactor-extract-sexp ()
"Extracts current innermost sexp (up to point) as a separate
"B" "BIN:"
"C:" "C-ENUM:" "C-STRUCT:" "C-UNION:" "CHAR:" "CONSTANT:" "call-next-method"
"DEFER:"
- "ERROR:" "EXCLUDE:"
+ "EBNF:" ";EBNF" "ERROR:" "EXCLUDE:"
"f" "FORGET:" "FROM:" "FUNCTION:"
"GENERIC#" "GENERIC:"
"HELP:" "HEX:" "HOOK:"
("\\_<<\\(\"\\)\\_>" (1 "<b"))
("\\_<\\(\"\\)>\\_>" (1 ">b"))
;; Multiline constructs
+ ("\\_<\\(E\\)BNF:\\( \\|\n\\)" (1 "<b"))
+ ("\\_<;EBN\\(F\\)\\_>" (1 ">b"))
("\\_<\\(U\\)SING: \\(;\\)" (1 "<b") (2 ">b"))
("\\_<USING:\\( \\)" (1 "<b"))
("\\_<\\(C\\)-ENUM: \\(;\\)" (1 "<b") (2 ">b"))
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];
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)
{
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)
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
{
{
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));
copy_handle(&compiled->literals);
copy_handle(&compiled->relocation);
-
- flush_icache_for(compiled);
}
void mark_stack_frame_step(F_STACK_FRAME *frame)
}
}
-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]);
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;
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,
/* 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);
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:
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)
userenv[CPU_ENV] = tag_object(from_char_string(FACTOR_CPU_STRING));
userenv[OS_ENV] = tag_object(from_char_string(FACTOR_OS_STRING));
userenv[CELL_SIZE_ENV] = tag_fixnum(sizeof(CELL));
- userenv[STACK_TRACES_ENV] = tag_boolean(p->stack_traces);
- userenv[EXECUTABLE_ENV] = (p->executable_path ?
- tag_object(from_native_string(p->executable_path)) : F);
+ userenv[EXECUTABLE_ENV] = (p->executable_path ? tag_object(from_native_string(p->executable_path)) : F);
userenv[ARGS_ENV] = F;
userenv[EMBEDDED_ENV] = F;
gc_off = false;
if(!stage2)
+ {
+ userenv[STACK_TRACES_ENV] = tag_boolean(p->stack_traces);
do_stage1_init();
+ }
}
/* May allocate memory */
}
}
+void primitive_fseek(void)
+{
+ int whence = to_fixnum(dpop());
+ FILE *file = unbox_alien();
+ off_t offset = to_signed_8(dpop());
+
+ switch(whence)
+ {
+ case 0: whence = SEEK_SET; break;
+ case 1: whence = SEEK_CUR; break;
+ case 2: whence = SEEK_END; break;
+ default:
+ critical_error("Bad value for whence",whence);
+ break;
+ }
+
+ if(FSEEK(file,offset,whence) == -1)
+ {
+ io_error();
+
+ /* Still here? EINTR */
+ critical_error("Don't know what to do; EINTR from fseek()?",0);
+ }
+}
+
void primitive_fflush(void)
{
FILE *file = unbox_alien();
void primitive_fputc(void);
void primitive_fwrite(void);
void primitive_fflush(void);
+void primitive_fseek(void);
void primitive_fclose(void);
/* Platform specific primitives */
#define STRNCMP strncmp
#define STRDUP strdup
+#define FSEEK fseeko
+
#define FIXNUM_FORMAT "%ld"
#define CELL_FORMAT "%lu"
#define CELL_HEX_FORMAT "%lx"
#define STRNCMP wcsncmp
#define STRDUP _wcsdup
#define MIN(a,b) ((a)>(b)?(b):(a))
+#define FSEEK fseek
#ifdef WIN64
#define CELL_FORMAT "%Iu"
#if defined(FACTOR_X86)
#include "os-solaris-x86.32.h"
#elif defined(FACTOR_AMD64)
- #incluide "os-solaris-x86.64.h"
+ #include "os-solaris-x86.64.h"
#else
#error "Unsupported Solaris flavor"
#endif
primitive_fputc,
primitive_fwrite,
primitive_fflush,
+ primitive_fseek,
primitive_fclose,
primitive_wrapper,
primitive_clone,
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));
projects / factor.git / commitdiff