From 34d7d6eaef69fd74ebc58fe43a80c32338288c7d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 3 Jan 2005 04:57:54 +0000 Subject: [PATCH 001/122] new ?ifte ?unless ?when combinators --- README.WIN32.txt | 20 +++++++++++++++++++ library/bootstrap/image.factor | 29 ++++++++-------------------- library/bootstrap/init-stage2.factor | 6 +----- library/combinators.factor | 22 +++++++++++++++++++++ library/compiler/alien-types.factor | 8 +++----- library/compiler/assembler.factor | 8 +++----- library/compiler/generator.factor | 6 +++--- library/compiler/xt.factor | 2 +- library/generic/generic.factor | 8 ++++---- library/inference/branches.factor | 8 +++----- library/inference/words.factor | 6 +++--- library/namespaces.factor | 14 +++++--------- library/syntax/parser.factor | 18 +++-------------- library/syntax/unparser.factor | 6 +----- library/test/combinators.factor | 8 ++++++++ library/tools/interpreter.factor | 14 +++++--------- library/vocabularies.factor | 10 +++------- version.factor | 2 +- 18 files changed, 97 insertions(+), 98 deletions(-) create mode 100644 README.WIN32.txt diff --git a/README.WIN32.txt b/README.WIN32.txt new file mode 100644 index 0000000000..0456ad39ff --- /dev/null +++ b/README.WIN32.txt @@ -0,0 +1,20 @@ +FACTOR ON WINDOWS + +The Windows port of Factor requires Windows 2000 or later. If you are +using Windows 95, 98 or NT, you might be able to get the Unix port of +Factor running inside Cygwin. Or you might not. + +A precompiled factor.exe is included with the download, along with +SDL.dll and SDL_gfx.dll. The SDL libraries are required for the +interactive interpreter. Factor does not use the Windows console, +because it does not support asynchronous I/O. + +To run the Windows port, open a DOS prompt and type: + + cd + + factor.exe boot.image.le32 +... Files are loaded and factor.image is written. + + factor.exe factor.image +... Factor starts the SDL console now. diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index 47d3336909..0fcbe52aae 100644 --- a/library/bootstrap/image.factor +++ b/library/bootstrap/image.factor @@ -215,18 +215,10 @@ M: f ' ( obj -- ptr ) : transfer-word ( word -- word ) #! This is a hack. See doc/bootstrap.txt. dup dup word-name swap word-vocabulary unit search - dup [ - nip - ] [ - drop "Missing DEFER: " word-error - ] ifte ; + [ "Missing DEFER: " word-error ] ?unless ; : fixup-word ( word -- offset ) - dup pooled-object dup [ - nip - ] [ - drop "Not in image: " word-error - ] ifte ; + dup pooled-object [ "Not in image: " word-error ] ?unless ; : fixup-words ( -- ) image get [ @@ -272,11 +264,9 @@ M: cons ' ( c -- tagged ) M: string ' ( string -- pointer ) #! We pool strings so that each string is only written once #! to the image - dup pooled-object dup [ - nip - ] [ - drop dup emit-string dup >r pool-object r> - ] ifte ; + dup pooled-object [ + dup emit-string dup >r pool-object r> + ] ?unless ; ( Arrays and vectors ) @@ -311,12 +301,9 @@ M: vector ' ( vector -- pointer ) M: hashtable ' ( hashtable -- pointer ) #! Only hashtables are pooled, not vectors! - dup pooled-object dup [ - nip - ] [ - drop [ dup emit-vector [ pool-object ] keep ] keep - rehash - ] ifte ; + dup pooled-object [ + [ dup emit-vector [ pool-object ] keep ] keep rehash + ] ?unless ; ( End of the image ) diff --git a/library/bootstrap/init-stage2.factor b/library/bootstrap/init-stage2.factor index f6c854405b..515e2dee8c 100644 --- a/library/bootstrap/init-stage2.factor +++ b/library/bootstrap/init-stage2.factor @@ -53,11 +53,7 @@ USE: console "smart-terminal" on "verbose-compile" on "compile" on - os "win32" = [ - "sdl" "shell" set - ] [ - "ansi" "shell" set - ] ifte ; + os "win32" = "sdl" "ansi" ? "shell" set ; : warm-boot ( -- ) #! A fully bootstrapped image has this as the boot diff --git a/library/combinators.factor b/library/combinators.factor index 394b8c981c..2c83e2a7c1 100644 --- a/library/combinators.factor +++ b/library/combinators.factor @@ -95,3 +95,25 @@ IN: kernel #! #! This combinator will not compile. dup slip forever ; + +: ?ifte ( default cond true false -- ) + #! If cond is true, drop default and apply true + #! quotation to cond. Otherwise, drop cond, and apply false + #! to default. + >r >r dup [ + nip r> r> drop call + ] [ + drop r> drop r> call + ] ifte ; inline + +: ?when ( default cond true -- ) + #! If cond is true, drop default and apply true + #! quotation to cond. Otherwise, drop cond, and leave + #! default on the stack. + >r dup [ nip r> call ] [ r> 2drop ] ifte ; inline + +: ?unless ( default cond false -- ) + #! If cond is true, drop default and leave cond on the + #! stack. Otherwise, drop default, and apply false + #! quotation to default. + >r dup [ nip r> drop ] [ drop r> call ] ifte ; inline diff --git a/library/compiler/alien-types.factor b/library/compiler/alien-types.factor index 20bafabaef..3aae8cf27b 100644 --- a/library/compiler/alien-types.factor +++ b/library/compiler/alien-types.factor @@ -72,11 +72,9 @@ USE: words : c-type ( name -- type ) global [ - dup "c-types" get hash dup [ - nip - ] [ - drop "No such C type: " swap cat2 throw f - ] ifte + dup "c-types" get hash [ + "No such C type: " swap cat2 throw f + ] ?unless ] bind ; : size ( name -- size ) diff --git a/library/compiler/assembler.factor b/library/compiler/assembler.factor index 9ed835805c..f279a60400 100644 --- a/library/compiler/assembler.factor +++ b/library/compiler/assembler.factor @@ -47,16 +47,14 @@ SYMBOL: interned-literals compiled-offset cell 2 * align set-compiled-offset ; inline : intern-literal ( obj -- lit# ) - dup interned-literals get hash dup [ - nip - ] [ - drop [ + dup interned-literals get hash [ + [ address literal-top set-compiled-cell literal-top dup cell + set-literal-top dup ] keep interned-literals get set-hash - ] ifte ; + ] ?unless ; : compile-byte ( n -- ) compiled-offset set-compiled-byte diff --git a/library/compiler/generator.factor b/library/compiler/generator.factor index 72a7bd5b2a..644f6171c5 100644 --- a/library/compiler/generator.factor +++ b/library/compiler/generator.factor @@ -62,11 +62,11 @@ SYMBOL: relocation-table : generate-node ( [ op | params ] -- ) #! Generate machine code for a node. - unswons dup "generator" word-property dup [ - nip call + unswons dup "generator" word-property [ + call ] [ "No generator" throw - ] ifte ; + ] ?ifte ; : generate-code ( word linear -- length ) compiled-offset >r diff --git a/library/compiler/xt.factor b/library/compiler/xt.factor index b3b510bbeb..f6fca61b5a 100644 --- a/library/compiler/xt.factor +++ b/library/compiler/xt.factor @@ -63,7 +63,7 @@ SYMBOL: compiled-xts compiled-xts off ; : compiled-xt ( word -- xt ) - dup compiled-xts get assoc [ nip ] [ word-xt ] ifte* ; + dup compiled-xts get assoc [ word-xt ] ?unless ; ! "deferred-xts" is a list of [ where word relative ] pairs; the ! xt of word when its done compiling will be written to the diff --git a/library/generic/generic.factor b/library/generic/generic.factor index 2cbdd9c364..5914b660ff 100644 --- a/library/generic/generic.factor +++ b/library/generic/generic.factor @@ -191,14 +191,14 @@ SYMBOL: object #! error if this is impossible. over builtin-supertypes over builtin-supertypes - intersection dup [ - nip nip lookup-union + intersection [ + nip lookup-union ] [ - drop [ + [ word-name , " and " , word-name , " do not intersect" , ] make-string throw - ] ifte ; + ] ?ifte ; : define-promise ( class -- ) #! A promise is a word that has no effect during diff --git a/library/inference/branches.factor b/library/inference/branches.factor index e30e0310cf..3e725e40e1 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -111,11 +111,9 @@ SYMBOL: cloned : deep-clone ( vector -- vector ) #! Clone a vector if it hasn't already been cloned in this #! with-deep-clone scope. - dup cloned get assoc dup [ - nip - ] [ - drop vector-clone [ dup cloned [ acons ] change ] keep - ] ifte ; + dup cloned get assoc [ + vector-clone [ dup cloned [ acons ] change ] keep + ] ?unless ; : deep-clone-vector ( vector -- vector ) #! Clone a vector of vectors. diff --git a/library/inference/words.factor b/library/inference/words.factor index 5f002a098f..cc013eb1ed 100644 --- a/library/inference/words.factor +++ b/library/inference/words.factor @@ -69,11 +69,11 @@ USE: prettyprint #! either execute the word in the meta interpreter (if it is #! side-effect-free and all parameters are literal), or #! simply apply its stack effect to the meta-interpreter. - over "infer" word-property dup [ + over "infer" word-property [ swap car ensure-d call drop ] [ - drop consume/produce - ] ifte ; + consume/produce + ] ifte* ; : no-effect ( word -- ) "Unknown stack effect: " swap word-name cat2 throw ; diff --git a/library/namespaces.factor b/library/namespaces.factor index c1f6ca523e..d5ab7f413c 100644 --- a/library/namespaces.factor +++ b/library/namespaces.factor @@ -79,11 +79,11 @@ USE: vectors : (get) ( var ns -- value ) #! Internal word for searching the namestack. dup [ - 2dup car hash* dup [ - nip nip cdr ( found ) + 2dup car hash* [ + nip cdr ( found ) ] [ - drop cdr (get) ( keep looking ) - ] ifte + cdr (get) ( keep looking ) + ] ?ifte ] [ 2drop f ] ifte ; @@ -99,11 +99,7 @@ USE: vectors : nest ( variable -- hash ) #! If the variable is set in the current namespace, return #! its value, otherwise set its value to a new namespace. - dup namespace hash dup [ - nip - ] [ - drop >r dup r> set - ] ifte ; + dup namespace hash [ >r dup r> set ] ?unless ; : change ( var quot -- ) #! Execute the quotation with the variable value on the diff --git a/library/syntax/parser.factor b/library/syntax/parser.factor index 4322ea64ec..6518079173 100644 --- a/library/syntax/parser.factor +++ b/library/syntax/parser.factor @@ -46,11 +46,7 @@ USE: unparser ! immediately. Otherwise it is appended to the parse tree. : parsing? ( word -- ? ) - dup word? [ - "parsing" word-property - ] [ - drop f - ] ifte ; + dup word? [ "parsing" word-property ] [ drop f ] ifte ; : end? ( -- ? ) "col" get "line" get str-length >= ; @@ -119,11 +115,7 @@ USE: unparser : scan-word ( -- obj ) scan dup [ - dup "use" get search dup [ - nip - ] [ - drop str>number - ] ifte + dup "use" get search [ str>number ] ?unless ] when ; : parsed| ( parsed parsed obj -- parsed ) @@ -131,11 +123,7 @@ USE: unparser >r unswons r> cons swap [ swons ] each swons ; : expect ( word -- ) - dup scan = not [ - "Expected " swap cat2 throw - ] [ - drop - ] ifte ; + dup scan = [ drop ] [ "Expected " swap cat2 throw ] ifte ; : parsed ( obj -- ) over "|" = [ nip parsed| "]" expect ] [ swons ] ifte ; diff --git a/library/syntax/unparser.factor b/library/syntax/unparser.factor index 16e013b377..1366b0e45b 100644 --- a/library/syntax/unparser.factor +++ b/library/syntax/unparser.factor @@ -117,11 +117,7 @@ M: complex unparse ( num -- str ) : unparse-ch ( ch -- ch/str ) dup quotable? [ - dup ch>ascii-escape dup [ - nip - ] [ - drop ch>unicode-escape - ] ifte + dup ch>ascii-escape [ ch>unicode-escape ] ?unless ] unless ; M: string unparse ( str -- str ) diff --git a/library/test/combinators.factor b/library/test/combinators.factor index f6f2dce321..fd8eb776bf 100644 --- a/library/test/combinators.factor +++ b/library/test/combinators.factor @@ -2,6 +2,8 @@ IN: scratchpad USE: kernel USE: math USE: test +USE: stdio +USE: prettyprint [ slip ] unit-test-fails [ 1 slip ] unit-test-fails @@ -25,3 +27,9 @@ USE: test [ 0 ] [ f [ 0 ] unless* ] unit-test [ t ] [ t [ "Hello" ] unless* ] unit-test + +[ "2\n" ] [ [ 1 2 [ . ] [ sq . ] ?ifte ] with-string ] unit-test +[ "9\n" ] [ [ 3 f [ . ] [ sq . ] ?ifte ] with-string ] unit-test +[ "4\n" ] [ [ 3 4 [ . ] ?when ] with-string ] unit-test +[ 3 ] [ 3 f [ . ] ?when ] unit-test +[ 3 ] [ 3 t [ . ] ?unless ] unit-test diff --git a/library/tools/interpreter.factor b/library/tools/interpreter.factor index 5f5748d84a..ae65b3039b 100644 --- a/library/tools/interpreter.factor +++ b/library/tools/interpreter.factor @@ -94,25 +94,21 @@ SYMBOL: meta-cf meta-cf [ [ push-r ] when* ] change ; : meta-word ( word -- ) - dup "meta-word" word-property dup [ - nip call + dup "meta-word" word-property [ + call ] [ - drop dup compound? [ + dup compound? [ word-parameter meta-call ] [ host-word ] ifte - ] ifte ; + ] ?ifte ; : do ( obj -- ) dup word? [ meta-word ] [ push-d ] ifte ; : meta-word-1 ( word -- ) - dup "meta-word" word-property dup [ - nip call - ] [ - drop host-word - ] ifte ; + dup "meta-word" word-property [ call ] [ host-word ] ?ifte ; : do-1 ( obj -- ) dup word? [ meta-word-1 ] [ push-d ] ifte ; diff --git a/library/vocabularies.factor b/library/vocabularies.factor index 71bedb18fa..9b4ad2c544 100644 --- a/library/vocabularies.factor +++ b/library/vocabularies.factor @@ -63,13 +63,9 @@ USE: strings : search ( name list -- word ) #! Search for a word in a list of vocabularies. dup [ - 2dup car (search) dup [ - nip nip ( found ) - ] [ - drop cdr search ( check next ) - ] ifte + 2dup car (search) [ nip ] [ cdr search ] ?ifte ] [ - 2drop f ( not found ) + 2drop f ] ifte ; : ( name vocab -- plist ) @@ -91,7 +87,7 @@ USE: strings #! Create a new word in a vocabulary. If the vocabulary #! already contains the word, the existing instance is #! returned. - 2dup (search) [ nip nip ] [ (create) dup reveal ] ifte* ; + 2dup (search) [ nip ] [ (create) dup reveal ] ?ifte ; : forget ( word -- ) #! Remove a word definition. diff --git a/version.factor b/version.factor index 91a69b512b..88f8a80f94 100644 --- a/version.factor +++ b/version.factor @@ -1,2 +1,2 @@ IN: kernel -: version "0.71" ; +: version "0.72" ; From 10d467937f47fa11c35d3a4e1a4ab571364f7631 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 3 Jan 2005 07:55:54 +0000 Subject: [PATCH 002/122] line editor --- factor/jedit/FactorPlugin.props | 2 +- library/bootstrap/boot-stage2.factor | 4 +- library/generic/traits.factor | 3 +- library/sbuf.factor | 3 + library/test/combinators.factor | 2 +- library/test/crashes.factor | 4 ++ library/test/test.factor | 1 + library/{sdl => ui}/console.factor | 58 ++++++++++++++---- library/ui/line-editor.factor | 91 ++++++++++++++++++++++++++++ native/string.c | 4 +- 10 files changed, 155 insertions(+), 17 deletions(-) rename library/{sdl => ui}/console.factor (74%) create mode 100644 library/ui/line-editor.factor diff --git a/factor/jedit/FactorPlugin.props b/factor/jedit/FactorPlugin.props index 7d36660d79..811bb4557f 100644 --- a/factor/jedit/FactorPlugin.props +++ b/factor/jedit/FactorPlugin.props @@ -2,7 +2,7 @@ plugin.factor.jedit.FactorPlugin.activate=startup plugin.factor.jedit.FactorPlugin.name=Factor -plugin.factor.jedit.FactorPlugin.version=0.71 +plugin.factor.jedit.FactorPlugin.version=0.72 plugin.factor.jedit.FactorPlugin.author=Slava Pestov plugin.factor.jedit.FactorPlugin.docs=/doc/jedit/index.html diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index b8b569c475..9d1ddb8729 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -137,7 +137,9 @@ USE: namespaces "/library/sdl/sdl-keyboard.factor" "/library/sdl/sdl-utils.factor" "/library/sdl/hsv.factor" - "/library/sdl/console.factor" + + "/library/ui/line-editor.factor" + "/library/ui/console.factor" "/library/bootstrap/image.factor" diff --git a/library/generic/traits.factor b/library/generic/traits.factor index 65cb3e72b0..3240fb16f0 100644 --- a/library/generic/traits.factor +++ b/library/generic/traits.factor @@ -38,7 +38,8 @@ USE: vectors ! Traits metaclass for user-defined classes based on hashtables -: traits ( object -- symbol ) \ traits swap hash ; +: traits ( object -- symbol ) + dup vector? [ \ traits swap hash ] [ drop f ] ifte ; ! Hashtable slot holding an optional delegate. Any undefined ! methods are called on the delegate. The object can also diff --git a/library/sbuf.factor b/library/sbuf.factor index c56f4c506d..d8c8ad6953 100644 --- a/library/sbuf.factor +++ b/library/sbuf.factor @@ -95,3 +95,6 @@ USE: strings : split-n ( n str -- list ) #! Split a string into n-character chunks. [ 0 -rot (split-n) ] make-list ; + +: ch>str ( ch -- str ) + 1 [ sbuf-append ] keep sbuf>str ; diff --git a/library/test/combinators.factor b/library/test/combinators.factor index fd8eb776bf..620658900d 100644 --- a/library/test/combinators.factor +++ b/library/test/combinators.factor @@ -32,4 +32,4 @@ USE: prettyprint [ "9\n" ] [ [ 3 f [ . ] [ sq . ] ?ifte ] with-string ] unit-test [ "4\n" ] [ [ 3 4 [ . ] ?when ] with-string ] unit-test [ 3 ] [ 3 f [ . ] ?when ] unit-test -[ 3 ] [ 3 t [ . ] ?unless ] unit-test +[ t ] [ 3 t [ . ] ?unless ] unit-test diff --git a/library/test/crashes.factor b/library/test/crashes.factor index c6a280851e..2a1bcb3fe4 100644 --- a/library/test/crashes.factor +++ b/library/test/crashes.factor @@ -9,6 +9,7 @@ USE: test USE: vectors USE: lists USE: words +USE: prettyprint ! Various things that broke CFactor at various times. ! This should run without issue (and tests nothing useful) @@ -62,3 +63,6 @@ USE: words [ 1 { } vector-nth ] [ garbage-collection drop ] catch [ -1 { } set-vector-length ] [ garbage-collection drop ] catch [ 1 "" str-nth ] [ garbage-collection drop ] catch + +! ... and again +[ "" 10 str/ ] [ . ] catch diff --git a/library/test/test.factor b/library/test/test.factor index 5757e6213d..54496d8c70 100644 --- a/library/test/test.factor +++ b/library/test/test.factor @@ -111,6 +111,7 @@ USE: unparser "interpreter" "hsv" "alien" + "line-editor" ] [ test ] each diff --git a/library/sdl/console.factor b/library/ui/console.factor similarity index 74% rename from library/sdl/console.factor rename to library/ui/console.factor index 66664500c0..144b86aa00 100644 --- a/library/sdl/console.factor +++ b/library/ui/console.factor @@ -1,3 +1,30 @@ +! :folding=indent:collapseFolds=1: + +! $Id$ +! +! Copyright (C) 2004, 2005 Slava Pestov. +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, +! this list of conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, +! this list of conditions and the following disclaimer in the documentation +! and/or other materials provided with the distribution. +! +! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, +! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; +! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + ! A graphical console. ! ! To run this code, bootstrap Factor like so: @@ -34,6 +61,7 @@ USE: listener USE: threads USE: stdio USE: errors +USE: line-editor #! A namespace holding console state. SYMBOL: console @@ -47,8 +75,8 @@ SYMBOL: x SYMBOL: y #! A string buffer. SYMBOL: output-line -#! A string buffer. -SYMBOL: line-editor +#! A line editor object. +SYMBOL: input-line ! Rendering : background HEX: 0000dbff ; @@ -94,7 +122,7 @@ SYMBOL: line-editor output-line get sbuf>str draw-line ; : draw-input ( -- ) - line-editor get sbuf>str draw-line draw-cursor ; + input-line get [ line-text get ] bind draw-line draw-cursor ; : draw-console ( -- ) [ @@ -187,7 +215,7 @@ PREDICATE: integer return-key M: return-key key-down ( key -- ) drop - line-editor get empty-buffer + input-line get [ line-text get line-clear ] bind dup console-write "\n" console-write input-continuation get call ; @@ -195,14 +223,22 @@ PREDICATE: integer backspace-key SDLK_BACKSPACE = ; M: backspace-key key-down ( key -- ) - line-editor get dup sbuf-length 0 = [ - drop - ] [ - [ sbuf-length 1 - ] keep set-sbuf-length - ] ifte ; + input-line get [ backspace ] bind ; + +PREDICATE: integer left-key + SDLK_LEFT = ; + +M: left-key key-down ( key -- ) + input-line get [ left ] bind ; + +PREDICATE: integer right-key + SDLK_RIGHT = ; + +M: right-key key-down ( key -- ) + input-line get [ right ] bind ; M: integer key-down ( key -- ) - line-editor get sbuf-append ; + input-line get [ insert-char ] bind ; GENERIC: handle-event ( event -- ? ) @@ -234,7 +270,7 @@ M: alien handle-event ( event -- ? ) event set 0 first-line set 80 lines set - 80 line-editor set + input-line set 80 output-line set 1 SDL_EnableUNICODE drop SDL_DEFAULT_REPEAT_DELAY SDL_DEFAULT_REPEAT_INTERVAL diff --git a/library/ui/line-editor.factor b/library/ui/line-editor.factor new file mode 100644 index 0000000000..5a6d0062fe --- /dev/null +++ b/library/ui/line-editor.factor @@ -0,0 +1,91 @@ +! :folding=indent:collapseFolds=1: + +! $Id$ +! +! Copyright (C) 2005 Slava Pestov. +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, +! this list of conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, +! this list of conditions and the following disclaimer in the documentation +! and/or other materials provided with the distribution. +! +! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, +! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; +! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +IN: line-editor +USE: namespaces +USE: strings +USE: kernel +USE: math + +SYMBOL: line-text +SYMBOL: caret + +: line-clear ( -- ) + #! Call this in the line editor scope. + 0 caret set "" line-text set ; + +: ( -- editor ) + [ line-clear ] extend ; + +: caret-insert ( str offset -- ) + #! Call this in the line editor scope. + caret get <= [ + str-length caret [ + ] change + ] [ + drop + ] ifte ; + +: line-insert ( str offset -- ) + #! Call this in the line editor scope. + 2dup caret-insert + line-text get swap str/ + swapd cat3 line-text set ; + +: insert-char ( ch -- ) + #! Call this in the line editor scope. + ch>str caret get line-insert ; + +: caret-remove ( offset length -- ) + #! Call this in the line editor scope. + 2dup + caret get <= [ + nip caret [ swap - ] change + ] [ + caret get pick pick dupd + between? [ + drop caret set + ] [ + 2drop + ] ifte + ] ifte ; + +: line-remove ( offset length -- ) + #! Call this in the line editor scope. + 2dup caret-remove + dupd + line-text get str-tail + >r line-text get str-head r> cat2 + line-text set ; + +: backspace ( -- ) + #! Call this in the line editor scope. + caret get dup 0 = [ drop ] [ 1 - 1 line-remove ] ifte ; + +: left ( -- ) + #! Call this in the line editor scope. + caret [ 1 - 0 max ] change ; + +: right ( -- ) + #! Call this in the line editor scope. + caret [ 1 + line-text str-length min ] change ; diff --git a/native/string.c b/native/string.c index 3c947e35d6..54a1accfbf 100644 --- a/native/string.c +++ b/native/string.c @@ -273,10 +273,10 @@ INLINE F_STRING* substring(CELL start, CELL end, F_STRING* string) F_STRING* result; if(start < 0) - range_error(tag_object(string),0,to_fixnum(start),string->capacity); + range_error(tag_object(string),0,tag_fixnum(start),string->capacity); if(end < start || end > string->capacity) - range_error(tag_object(string),0,to_fixnum(end),string->capacity); + range_error(tag_object(string),0,tag_fixnum(end),string->capacity); result = allot_string(end - start); memcpy(result + 1, From 37f9fd2a2e2b96a03cfb5bb9ed50be07c9f31430 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 3 Jan 2005 21:39:17 +0000 Subject: [PATCH 003/122] line editing --- library/sdl/sdl-keyboard.factor | 27 ++ library/sdl/sdl-keysym.factor | 514 ++++++++++++++++---------------- library/test/line-editor.factor | 71 +++++ library/ui/console.factor | 102 ++++--- library/ui/line-editor.factor | 2 +- 5 files changed, 424 insertions(+), 292 deletions(-) create mode 100644 library/test/line-editor.factor diff --git a/library/sdl/sdl-keyboard.factor b/library/sdl/sdl-keyboard.factor index 8efc1bcf53..5198d5f6db 100644 --- a/library/sdl/sdl-keyboard.factor +++ b/library/sdl/sdl-keyboard.factor @@ -27,6 +27,13 @@ IN: sdl-keyboard USE: alien +USE: lists +USE: sdl-keysym +USE: namespaces +USE: sdl-event +USE: kernel +USE: math +USE: hashtables : SDL_EnableUNICODE ( enable -- ) "int" "sdl" "SDL_EnableUNICODE" [ "int" ] alien-invoke ; @@ -36,3 +43,23 @@ USE: alien : SDL_EnableKeyRepeat ( delay interval -- ) "int" "sdl" "SDL_EnableKeyRepeat" [ "int" "int" ] alien-invoke ; + +: modifiers, ( mod -- ) + modifiers get [ + uncons pick bitand 0 = [ drop ] [ unique, ] ifte + ] each + drop ; + +: keysym, ( sym -- ) + #! Return the original keysym number if its unknown. + [ keysyms get hash dup ] keep ? , ; + +: keyboard-event>binding ( event -- binding ) + #! Turn a key event into a binding, which is a list where + #! all elements but the last one are modifier names looked + #! up the modifiers alist, and the last element is a keysym + #! look up in the keysyms hash. + [ + dup keyboard-event-mod modifiers, + keyboard-event-sym keysym, + ] make-list ; diff --git a/library/sdl/sdl-keysym.factor b/library/sdl/sdl-keysym.factor index 26bdd269fc..a12fead242 100644 --- a/library/sdl/sdl-keysym.factor +++ b/library/sdl/sdl-keysym.factor @@ -25,258 +25,272 @@ ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE ; EVEN IF ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -IN: sdl-keysym +IN: sdl-keyboard +USE: namespaces -! The keyboard syms have been cleverly chosen to map to ASCII -: SDLK_UNKNOWN 0 ; -: SDLK_FIRST 0 ; -: SDLK_BACKSPACE 8 ; -: SDLK_TAB 9 ; -: SDLK_CLEAR 12 ; -: SDLK_RETURN 13 ; -: SDLK_PAUSE 19 ; -: SDLK_ESCAPE 27 ; -: SDLK_SPACE 32 ; -: SDLK_EXCLAIM 33 ; -: SDLK_QUOTEDBL 34 ; -: SDLK_HASH 35 ; -: SDLK_DOLLAR 36 ; -: SDLK_AMPERSAND 38 ; -: SDLK_QUOTE 39 ; -: SDLK_LEFTPAREN 40 ; -: SDLK_RIGHTPAREN 41 ; -: SDLK_ASTERISK 42 ; -: SDLK_PLUS 43 ; -: SDLK_COMMA 44 ; -: SDLK_MINUS 45 ; -: SDLK_PERIOD 46 ; -: SDLK_SLASH 47 ; -: SDLK_0 48 ; -: SDLK_1 49 ; -: SDLK_2 50 ; -: SDLK_3 51 ; -: SDLK_4 52 ; -: SDLK_5 53 ; -: SDLK_6 54 ; -: SDLK_7 55 ; -: SDLK_8 56 ; -: SDLK_9 57 ; -: SDLK_COLON 58 ; -: SDLK_SEMICOLON 59 ; -: SDLK_LESS 60 ; -: SDLK_EQUALS 61 ; -: SDLK_GREATER 62 ; -: SDLK_QUESTION 63 ; -: SDLK_AT 64 ; +! Here we smash left/right control/shift/alt for convinience. +! Later, something better needs to be done. -! Skip uppercase letters -: SDLK_LEFTBRACKET 91 ; -: SDLK_BACKSLASH 92 ; -: SDLK_RIGHTBRACKET 93 ; -: SDLK_CARET 94 ; -: SDLK_UNDERSCORE 95 ; -: SDLK_BACKQUOTE 96 ; -: SDLK_a 97 ; -: SDLK_b 98 ; -: SDLK_c 99 ; -: SDLK_d 100 ; -: SDLK_e 101 ; -: SDLK_f 102 ; -: SDLK_g 103 ; -: SDLK_h 104 ; -: SDLK_i 105 ; -: SDLK_j 106 ; -: SDLK_k 107 ; -: SDLK_l 108 ; -: SDLK_m 109 ; -: SDLK_n 110 ; -: SDLK_o 111 ; -: SDLK_p 112 ; -: SDLK_q 113 ; -: SDLK_r 114 ; -: SDLK_s 115 ; -: SDLK_t 116 ; -: SDLK_u 117 ; -: SDLK_v 118 ; -: SDLK_w 119 ; -: SDLK_x 120 ; -: SDLK_y 121 ; -: SDLK_z 122 ; -: SDLK_DELETE 127 ; +SYMBOL: modifiers -! End of ASCII mapped keysyms +[ + [ "SHIFT" | HEX: 0001 ] + [ "SHIFT" | HEX: 0002 ] + [ "CTRL" | HEX: 0040 ] + [ "CTRL" | HEX: 0080 ] + [ "ALT" | HEX: 0100 ] + [ "ALT" | HEX: 0200 ] + [ "META" | HEX: 0400 ] + [ "META" | HEX: 0800 ] + [ "NUM" | HEX: 1000 ] + [ "CAPS" | HEX: 2000 ] + [ "MODE" | HEX: 4000 ] +] modifiers set -! International keyboard syms +SYMBOL: keysyms -: SDLK_WORLD_0 160 ; ! 0xA0 -: SDLK_WORLD_1 161 ; -: SDLK_WORLD_2 162 ; -: SDLK_WORLD_3 163 ; -: SDLK_WORLD_4 164 ; -: SDLK_WORLD_5 165 ; -: SDLK_WORLD_6 166 ; -: SDLK_WORLD_7 167 ; -: SDLK_WORLD_8 168 ; -: SDLK_WORLD_9 169 ; -: SDLK_WORLD_10 170 ; -: SDLK_WORLD_11 171 ; -: SDLK_WORLD_12 172 ; -: SDLK_WORLD_13 173 ; -: SDLK_WORLD_14 174 ; -: SDLK_WORLD_15 175 ; -: SDLK_WORLD_16 176 ; -: SDLK_WORLD_17 177 ; -: SDLK_WORLD_18 178 ; -: SDLK_WORLD_19 179 ; -: SDLK_WORLD_20 180 ; -: SDLK_WORLD_21 181 ; -: SDLK_WORLD_22 182 ; -: SDLK_WORLD_23 183 ; -: SDLK_WORLD_24 184 ; -: SDLK_WORLD_25 185 ; -: SDLK_WORLD_26 186 ; -: SDLK_WORLD_27 187 ; -: SDLK_WORLD_28 188 ; -: SDLK_WORLD_29 189 ; -: SDLK_WORLD_30 190 ; -: SDLK_WORLD_31 191 ; -: SDLK_WORLD_32 192 ; -: SDLK_WORLD_33 193 ; -: SDLK_WORLD_34 194 ; -: SDLK_WORLD_35 195 ; -: SDLK_WORLD_36 196 ; -: SDLK_WORLD_37 197 ; -: SDLK_WORLD_38 198 ; -: SDLK_WORLD_39 199 ; -: SDLK_WORLD_40 200 ; -: SDLK_WORLD_41 201 ; -: SDLK_WORLD_42 202 ; -: SDLK_WORLD_43 203 ; -: SDLK_WORLD_44 204 ; -: SDLK_WORLD_45 205 ; -: SDLK_WORLD_46 206 ; -: SDLK_WORLD_47 207 ; -: SDLK_WORLD_48 208 ; -: SDLK_WORLD_49 209 ; -: SDLK_WORLD_50 210 ; -: SDLK_WORLD_51 211 ; -: SDLK_WORLD_52 212 ; -: SDLK_WORLD_53 213 ; -: SDLK_WORLD_54 214 ; -: SDLK_WORLD_55 215 ; -: SDLK_WORLD_56 216 ; -: SDLK_WORLD_57 217 ; -: SDLK_WORLD_58 218 ; -: SDLK_WORLD_59 219 ; -: SDLK_WORLD_60 220 ; -: SDLK_WORLD_61 221 ; -: SDLK_WORLD_62 222 ; -: SDLK_WORLD_63 223 ; -: SDLK_WORLD_64 224 ; -: SDLK_WORLD_65 225 ; -: SDLK_WORLD_66 226 ; -: SDLK_WORLD_67 227 ; -: SDLK_WORLD_68 228 ; -: SDLK_WORLD_69 229 ; -: SDLK_WORLD_70 230 ; -: SDLK_WORLD_71 231 ; -: SDLK_WORLD_72 232 ; -: SDLK_WORLD_73 233 ; -: SDLK_WORLD_74 234 ; -: SDLK_WORLD_75 235 ; -: SDLK_WORLD_76 236 ; -: SDLK_WORLD_77 237 ; -: SDLK_WORLD_78 238 ; -: SDLK_WORLD_79 239 ; -: SDLK_WORLD_80 240 ; -: SDLK_WORLD_81 241 ; -: SDLK_WORLD_82 242 ; -: SDLK_WORLD_83 243 ; -: SDLK_WORLD_84 244 ; -: SDLK_WORLD_85 245 ; -: SDLK_WORLD_86 246 ; -: SDLK_WORLD_87 247 ; -: SDLK_WORLD_88 248 ; -: SDLK_WORLD_89 249 ; -: SDLK_WORLD_90 250 ; -: SDLK_WORLD_91 251 ; -: SDLK_WORLD_92 252 ; -: SDLK_WORLD_93 253 ; -: SDLK_WORLD_94 254 ; -: SDLK_WORLD_95 255 ; ! 0xFF - -! Numeric keypad -: SDLK_KP0 256 ; -: SDLK_KP1 257 ; -: SDLK_KP2 258 ; -: SDLK_KP3 259 ; -: SDLK_KP4 260 ; -: SDLK_KP5 261 ; -: SDLK_KP6 262 ; -: SDLK_KP7 263 ; -: SDLK_KP8 264 ; -: SDLK_KP9 265 ; -: SDLK_KP_PERIOD 266 ; -: SDLK_KP_DIVIDE 267 ; -: SDLK_KP_MULTIPLY 268 ; -: SDLK_KP_MINUS 269 ; -: SDLK_KP_PLUS 270 ; -: SDLK_KP_ENTER 271 ; -: SDLK_KP_EQUALS 272 ; - -! Arrows + Home/End pad -: SDLK_UP 273 ; -: SDLK_DOWN 274 ; -: SDLK_RIGHT 275 ; -: SDLK_LEFT 276 ; -: SDLK_INSERT 277 ; -: SDLK_HOME 278 ; -: SDLK_END 279 ; -: SDLK_PAGEUP 280 ; -: SDLK_PAGEDOWN 281 ; - -! Function keys -: SDLK_F1 282 ; -: SDLK_F2 283 ; -: SDLK_F3 284 ; -: SDLK_F4 285 ; -: SDLK_F5 286 ; -: SDLK_F6 287 ; -: SDLK_F7 288 ; -: SDLK_F8 289 ; -: SDLK_F9 290 ; -: SDLK_F10 291 ; -: SDLK_F11 292 ; -: SDLK_F12 293 ; -: SDLK_F13 294 ; -: SDLK_F14 295 ; -: SDLK_F15 296 ; - -! Key state modifier keys -: SDLK_NUMLOCK 300 ; -: SDLK_CAPSLOCK 301 ; -: SDLK_SCROLLOCK 302 ; -: SDLK_RSHIFT 303 ; -: SDLK_LSHIFT 304 ; -: SDLK_RCTRL 305 ; -: SDLK_LCTRL 306 ; -: SDLK_RALT 307 ; -: SDLK_LALT 308 ; -: SDLK_RMETA 309 ; -: SDLK_LMETA 310 ; -: SDLK_LSUPER 311 ; ! Left "Windows" key -: SDLK_RSUPER 312 ; ! Right "Windows" key -: SDLK_MODE 313 ; ! "Alt Gr" key -: SDLK_COMPOSE 314 ; ! Multi-key compose key - -! Miscellaneous function keys -: SDLK_HELP 315 ; -: SDLK_PRINT 316 ; -: SDLK_SYSREQ 317 ; -: SDLK_BREAK 318 ; -: SDLK_MENU 319 ; -: SDLK_POWER 320 ; ! Power Macintosh power key -: SDLK_EURO 321 ; ! Some european keyboards -: SDLK_UNDO 322 ; ! Atari keyboard has Undo - -! Add any other keys here +{{ + ! The keyboard syms have been cleverly chosen to map to ASCII + [ 0 | "UNKNOWN" ] +! [ 0 | "FIRST" ] + [ 8 | "BACKSPACE" ] + [ 9 | "TAB" ] + [ 12 | "CLEAR" ] + [ 13 | "RETURN" ] + [ 19 | "PAUSE" ] + [ 27 | "ESCAPE" ] + [ 32 | "SPACE" ] + [ 33 | "EXCLAIM" ] + [ 34 | "QUOTEDBL" ] + [ 35 | "HASH" ] + [ 36 | "DOLLAR" ] + [ 38 | "AMPERSAND" ] + [ 39 | "QUOTE" ] + [ 40 | "LEFTPAREN" ] + [ 41 | "RIGHTPAREN" ] + [ 42 | "ASTERISK" ] + [ 43 | "PLUS" ] + [ 44 | "COMMA" ] + [ 45 | "MINUS" ] + [ 46 | "PERIOD" ] + [ 47 | "SLASH" ] + [ 48 | 0 ] + [ 49 | 1 ] + [ 50 | 2 ] + [ 51 | 3 ] + [ 52 | 4 ] + [ 53 | 5 ] + [ 54 | 6 ] + [ 55 | 7 ] + [ 56 | 8 ] + [ 57 | 9 ] + [ 58 | "COLON" ] + [ 59 | "SEMICOLON" ] + [ 60 | "LESS" ] + [ 61 | "EQUALS" ] + [ 62 | "GREATER" ] + [ 63 | "QUESTION" ] + [ 64 | "AT" ] + ! Skip uppercase letters + [ 91 | "LEFTBRACKET" ] + [ 92 | "BACKSLASH" ] + [ 93 | "RIGHTBRACKET" ] + [ 94 | "CARET" ] + [ 95 | "UNDERSCORE" ] + [ 96 | "BACKQUOTE" ] + [ 97 | "a" ] + [ 98 | "b" ] + [ 99 | "c" ] + [ 100 | "d" ] + [ 101 | "e" ] + [ 102 | "f" ] + [ 103 | "g" ] + [ 104 | "h" ] + [ 105 | "i" ] + [ 106 | "j" ] + [ 107 | "k" ] + [ 108 | "l" ] + [ 109 | "m" ] + [ 110 | "n" ] + [ 111 | "o" ] + [ 112 | "p" ] + [ 113 | "q" ] + [ 114 | "r" ] + [ 115 | "s" ] + [ 116 | "t" ] + [ 117 | "u" ] + [ 118 | "v" ] + [ 119 | "w" ] + [ 120 | "x" ] + [ 121 | "y" ] + [ 122 | "z" ] + [ 127 | "DELETE" ] + ! End of ASCII mapped keysyms + ! International keyboard syms + [ 160 | "WORLD_0" ] ! 0xA0 + [ 161 | "WORLD_1" ] + [ 162 | "WORLD_2" ] + [ 163 | "WORLD_3" ] + [ 164 | "WORLD_4" ] + [ 165 | "WORLD_5" ] + [ 166 | "WORLD_6" ] + [ 167 | "WORLD_7" ] + [ 168 | "WORLD_8" ] + [ 169 | "WORLD_9" ] + [ 170 | "WORLD_10" ] + [ 171 | "WORLD_11" ] + [ 172 | "WORLD_12" ] + [ 173 | "WORLD_13" ] + [ 174 | "WORLD_14" ] + [ 175 | "WORLD_15" ] + [ 176 | "WORLD_16" ] + [ 177 | "WORLD_17" ] + [ 178 | "WORLD_18" ] + [ 179 | "WORLD_19" ] + [ 180 | "WORLD_20" ] + [ 181 | "WORLD_21" ] + [ 182 | "WORLD_22" ] + [ 183 | "WORLD_23" ] + [ 184 | "WORLD_24" ] + [ 185 | "WORLD_25" ] + [ 186 | "WORLD_26" ] + [ 187 | "WORLD_27" ] + [ 188 | "WORLD_28" ] + [ 189 | "WORLD_29" ] + [ 190 | "WORLD_30" ] + [ 191 | "WORLD_31" ] + [ 192 | "WORLD_32" ] + [ 193 | "WORLD_33" ] + [ 194 | "WORLD_34" ] + [ 195 | "WORLD_35" ] + [ 196 | "WORLD_36" ] + [ 197 | "WORLD_37" ] + [ 198 | "WORLD_38" ] + [ 199 | "WORLD_39" ] + [ 200 | "WORLD_40" ] + [ 201 | "WORLD_41" ] + [ 202 | "WORLD_42" ] + [ 203 | "WORLD_43" ] + [ 204 | "WORLD_44" ] + [ 205 | "WORLD_45" ] + [ 206 | "WORLD_46" ] + [ 207 | "WORLD_47" ] + [ 208 | "WORLD_48" ] + [ 209 | "WORLD_49" ] + [ 210 | "WORLD_50" ] + [ 211 | "WORLD_51" ] + [ 212 | "WORLD_52" ] + [ 213 | "WORLD_53" ] + [ 214 | "WORLD_54" ] + [ 215 | "WORLD_55" ] + [ 216 | "WORLD_56" ] + [ 217 | "WORLD_57" ] + [ 218 | "WORLD_58" ] + [ 219 | "WORLD_59" ] + [ 220 | "WORLD_60" ] + [ 221 | "WORLD_61" ] + [ 222 | "WORLD_62" ] + [ 223 | "WORLD_63" ] + [ 224 | "WORLD_64" ] + [ 225 | "WORLD_65" ] + [ 226 | "WORLD_66" ] + [ 227 | "WORLD_67" ] + [ 228 | "WORLD_68" ] + [ 229 | "WORLD_69" ] + [ 230 | "WORLD_70" ] + [ 231 | "WORLD_71" ] + [ 232 | "WORLD_72" ] + [ 233 | "WORLD_73" ] + [ 234 | "WORLD_74" ] + [ 235 | "WORLD_75" ] + [ 236 | "WORLD_76" ] + [ 237 | "WORLD_77" ] + [ 238 | "WORLD_78" ] + [ 239 | "WORLD_79" ] + [ 240 | "WORLD_80" ] + [ 241 | "WORLD_81" ] + [ 242 | "WORLD_82" ] + [ 243 | "WORLD_83" ] + [ 244 | "WORLD_84" ] + [ 245 | "WORLD_85" ] + [ 246 | "WORLD_86" ] + [ 247 | "WORLD_87" ] + [ 248 | "WORLD_88" ] + [ 249 | "WORLD_89" ] + [ 250 | "WORLD_90" ] + [ 251 | "WORLD_91" ] + [ 252 | "WORLD_92" ] + [ 253 | "WORLD_93" ] + [ 254 | "WORLD_94" ] + [ 255 | "WORLD_95" ] ! 0xFF + ! Numeric keypad + [ 256 | "KP0" ] + [ 257 | "KP1" ] + [ 258 | "KP2" ] + [ 259 | "KP3" ] + [ 260 | "KP4" ] + [ 261 | "KP5" ] + [ 262 | "KP6" ] + [ 263 | "KP7" ] + [ 264 | "KP8" ] + [ 265 | "KP9" ] + [ 266 | "KP_PERIOD" ] + [ 267 | "KP_DIVIDE" ] + [ 268 | "KP_MULTIPLY" ] + [ 269 | "KP_MINUS" ] + [ 270 | "KP_PLUS" ] + [ 271 | "KP_ENTER" ] + [ 272 | "KP_EQUALS" ] + ! Arrows + Home/End pad + [ 273 | "UP" ] + [ 274 | "DOWN" ] + [ 275 | "RIGHT" ] + [ 276 | "LEFT" ] + [ 277 | "INSERT" ] + [ 278 | "HOME" ] + [ 279 | "END" ] + [ 280 | "PAGEUP" ] + [ 281 | "PAGEDOWN" ] + ! Function keys + [ 282 | "F1" ] + [ 283 | "F2" ] + [ 284 | "F3" ] + [ 285 | "F4" ] + [ 286 | "F5" ] + [ 287 | "F6" ] + [ 288 | "F7" ] + [ 289 | "F8" ] + [ 290 | "F9" ] + [ 291 | "F10" ] + [ 292 | "F11" ] + [ 293 | "F12" ] + [ 294 | "F13" ] + [ 295 | "F14" ] + [ 296 | "F15" ] + ! Key state modifier keys + [ 300 | "NUMLOCK" ] + [ 301 | "CAPSLOCK" ] + [ 302 | "SCROLLOCK" ] + [ 303 | "RSHIFT" ] + [ 304 | "LSHIFT" ] + [ 305 | "RCTRL" ] + [ 306 | "LCTRL" ] + [ 307 | "RALT" ] + [ 308 | "LALT" ] + [ 309 | "RMETA" ] + [ 310 | "LMETA" ] + [ 311 | "LSUPER" ] ! Left "Windows" key + [ 312 | "RSUPER" ] ! Right "Windows" key + [ 313 | "MODE" ] ! "Alt Gr" key + [ 314 | "COMPOSE" ] ! Multi-key compose key + ! Miscellaneous function keys + [ 315 | "HELP" ] + [ 316 | "PRINT" ] + [ 317 | "SYSREQ" ] + [ 318 | "BREAK" ] + [ 319 | "MENU" ] + [ 320 | "POWER" ] ! Power Macintosh power key + [ 321 | "EURO" ] ! Some european keyboards + [ 322 | "UNDO" ] ! Atari keyboard has Undo + ! Add any other keys here +}} keysyms set diff --git a/library/test/line-editor.factor b/library/test/line-editor.factor new file mode 100644 index 0000000000..19ac2ecf4b --- /dev/null +++ b/library/test/line-editor.factor @@ -0,0 +1,71 @@ +IN: scratchpad +USE: namespaces +USE: line-editor +USE: test +USE: strings +USE: kernel +USE: prettyprint + + "editor" set + +[ "Hello world" ] [ + "Hello world" 0 "editor" get [ line-insert ] bind + "editor" get [ line-text get ] bind +] unit-test + +[ t ] [ + "editor" get [ caret get ] bind + "Hello world" str-length = +] unit-test + +[ "Hello, crazy world" ] [ + "editor" get [ 0 caret set ] bind + ", crazy" 5 "editor" get [ line-insert ] bind + "editor" get [ line-text get ] bind +] unit-test + +[ 0 ] [ "editor" get [ caret get ] bind ] unit-test + +[ "Hello, crazy world" ] [ + "editor" get [ 5 caret set "Hello world" line-text set ] bind + ", crazy" 5 "editor" get [ line-insert ] bind + "editor" get [ line-text get ] bind +] unit-test + +[ "Hello, crazy" ] [ + "editor" get [ caret get line-text get str-head ] bind +] unit-test + +[ 0 ] +[ + [ + 0 caret set + 3 2 caret-remove + caret get + ] with-scope +] unit-test + +[ 3 ] +[ + [ + 4 caret set + 3 6 caret-remove + caret get + ] with-scope +] unit-test + +[ 5 ] +[ + [ + 8 caret set + 3 3 caret-remove + caret get + ] with-scope +] unit-test + +[ "Hellorld" ] +[ + "editor" get [ 0 caret set "Hello world" line-text set ] bind + 4 3 "editor" get [ line-remove ] bind + "editor" get [ line-text get ] bind +] unit-test diff --git a/library/ui/console.factor b/library/ui/console.factor index 144b86aa00..8cb32eec83 100644 --- a/library/ui/console.factor +++ b/library/ui/console.factor @@ -62,6 +62,7 @@ USE: threads USE: stdio USE: errors USE: line-editor +USE: hashtables #! A namespace holding console state. SYMBOL: console @@ -110,19 +111,24 @@ SYMBOL: input-line next-line ] times* ; -: draw-cursor ( -- ) +: draw-cursor ( x -- ) surface get - x get + swap y get - x get char-width + + over 1 + y get line-height + cursor boxColor ; : draw-current ( -- ) output-line get sbuf>str draw-line ; +: caret-x ( -- x ) + x get input-line get [ caret get char-width * + ] bind ; + : draw-input ( -- ) - input-line get [ line-text get ] bind draw-line draw-cursor ; + caret-x >r + input-line get [ line-text get ] bind draw-line + r> draw-cursor ; : draw-console ( -- ) [ @@ -202,51 +208,65 @@ M: console-stream fclose ( stream -- ) drop ; ! Event handling SYMBOL: event -GENERIC: key-down ( key -- ) +: valid-char? 1 255 between? ; -PREDICATE: integer null-key - dup 0 = swap 255 > or ; - -M: null-key key-down ( key -- ) - drop ; - -PREDICATE: integer return-key - SDLK_RETURN = ; - -M: return-key key-down ( key -- ) - drop - input-line get [ line-text get line-clear ] bind - dup console-write "\n" console-write - input-continuation get call ; - -PREDICATE: integer backspace-key - SDLK_BACKSPACE = ; - -M: backspace-key key-down ( key -- ) - input-line get [ backspace ] bind ; - -PREDICATE: integer left-key - SDLK_LEFT = ; - -M: left-key key-down ( key -- ) - input-line get [ left ] bind ; - -PREDICATE: integer right-key - SDLK_RIGHT = ; - -M: right-key key-down ( key -- ) - input-line get [ right ] bind ; - -M: integer key-down ( key -- ) - input-line get [ insert-char ] bind ; +! +! M: null-key key-down ( key -- ) +! drop ; +! +! PREDICATE: integer return-key +! SDLK_RETURN = ; +! +: return-key + input-line get [ line-text get line-clear ] bind + dup console-write "\n" console-write + input-continuation get call ; +! +! PREDICATE: integer backspace-key +! SDLK_BACKSPACE = ; +! +! M: backspace-key key-down ( key -- ) +! input-line get [ backspace ] bind ; +! +! PREDICATE: integer left-key +! SDLK_LEFT = ; +! +! M: left-key key-down ( key -- ) +! input-line get [ left ] bind ; +! +! PREDICATE: integer right-key +! SDLK_RIGHT = ; +! +! M: right-key key-down ( key -- ) +! input-line get [ right ] bind ; +! +! M: integer key-down ( key -- ) +! input-line get [ insert-char ] bind ; GENERIC: handle-event ( event -- ? ) PREDICATE: alien key-down-event keyboard-event-type SDL_KEYDOWN = ; +SYMBOL: keymap + +{{ + [ [ "RETURN" ] | [ return-key ] ] + [ [ "BACKSPACE" ] | [ input-line get [ backspace ] bind ] ] + [ [ "LEFT" ] | [ input-line get [ left ] bind ] ] + [ [ "RIGHT" ] | [ input-line get [ right ] bind ] ] +}} keymap set + M: key-down-event handle-event ( event -- ? ) - keyboard-event-unicode key-down draw-console t ; + dup keyboard-event>binding keymap get hash [ + call draw-console + ] [ + keyboard-event-unicode dup valid-char? [ + input-line get [ insert-char ] bind draw-console + ] [ + drop + ] ifte + ] ?ifte t ; PREDICATE: alien quit-event quit-event-type SDL_QUIT = ; diff --git a/library/ui/line-editor.factor b/library/ui/line-editor.factor index 5a6d0062fe..8988d437f6 100644 --- a/library/ui/line-editor.factor +++ b/library/ui/line-editor.factor @@ -88,4 +88,4 @@ SYMBOL: caret : right ( -- ) #! Call this in the line editor scope. - caret [ 1 + line-text str-length min ] change ; + caret [ 1 + line-text get str-length min ] change ; From 70bf36080e170ae4880fa3509ca20b72178e1c0f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 4 Jan 2005 05:41:14 +0000 Subject: [PATCH 004/122] line editor history --- library/ui/console.factor | 40 ++++++----------------- library/ui/line-editor.factor | 61 +++++++++++++++++++++++++++++++++-- 2 files changed, 69 insertions(+), 32 deletions(-) diff --git a/library/ui/console.factor b/library/ui/console.factor index 8cb32eec83..7a8540aee5 100644 --- a/library/ui/console.factor +++ b/library/ui/console.factor @@ -53,7 +53,6 @@ USE: math USE: kernel USE: strings USE: alien -USE: sdl-keysym USE: sdl-keyboard USE: streams USE: prettyprint @@ -111,6 +110,8 @@ SYMBOL: input-line next-line ] times* ; +: blink-interval 500 ; + : draw-cursor ( x -- ) surface get swap @@ -210,38 +211,14 @@ SYMBOL: event : valid-char? 1 255 between? ; -! -! M: null-key key-down ( key -- ) -! drop ; -! -! PREDICATE: integer return-key -! SDLK_RETURN = ; -! : return-key - input-line get [ line-text get line-clear ] bind + input-line get [ + commit-history + line-text get + line-clear + ] bind dup console-write "\n" console-write input-continuation get call ; -! -! PREDICATE: integer backspace-key -! SDLK_BACKSPACE = ; -! -! M: backspace-key key-down ( key -- ) -! input-line get [ backspace ] bind ; -! -! PREDICATE: integer left-key -! SDLK_LEFT = ; -! -! M: left-key key-down ( key -- ) -! input-line get [ left ] bind ; -! -! PREDICATE: integer right-key -! SDLK_RIGHT = ; -! -! M: right-key key-down ( key -- ) -! input-line get [ right ] bind ; -! -! M: integer key-down ( key -- ) -! input-line get [ insert-char ] bind ; GENERIC: handle-event ( event -- ? ) @@ -255,6 +232,9 @@ SYMBOL: keymap [ [ "BACKSPACE" ] | [ input-line get [ backspace ] bind ] ] [ [ "LEFT" ] | [ input-line get [ left ] bind ] ] [ [ "RIGHT" ] | [ input-line get [ right ] bind ] ] + [ [ "UP" ] | [ input-line get [ history-prev ] bind ] ] + [ [ "DOWN" ] | [ input-line get [ history-next ] bind ] ] + [ [ "CTRL" "k" ] | [ input-line get [ line-clear ] bind ] ] }} keymap set M: key-down-event handle-event ( event -- ? ) diff --git a/library/ui/line-editor.factor b/library/ui/line-editor.factor index 8988d437f6..4691a38ca6 100644 --- a/library/ui/line-editor.factor +++ b/library/ui/line-editor.factor @@ -30,16 +30,71 @@ USE: namespaces USE: strings USE: kernel USE: math +USE: vectors SYMBOL: line-text SYMBOL: caret +! History stuff +SYMBOL: history +SYMBOL: history-index + +: history-length ( -- n ) + #! Call this in the line editor scope. + history get vector-length ; + +: reset-history ( -- ) + #! Call this in the line editor scope. After user input, + #! resets the history index. + history-length history-index set ; + +: commit-history ( -- ) + #! Call this in the line editor scope. Adds the currently + #! entered text to the history. + line-text get dup "" = [ + drop + ] [ + history-index get history get set-vector-nth + reset-history + ] ifte ; + +: set-line-text ( text -- ) + #! Call this in the line editor scope. + dup line-text set str-length caret set ; + +: goto-history ( n -- ) + #! Call this in the line editor scope. + dup history-index set + history get vector-nth set-line-text ; + +: history-prev ( -- ) + #! Call this in the line editor scope. + history-index get dup 0 = [ + drop + ] [ + dup history-length = [ commit-history ] when + 1 - goto-history + ] ifte ; + +: history-next ( -- ) + #! Call this in the line editor scope. + history-index get dup 1 + history-length >= [ + drop + ] [ + 1 + goto-history + ] ifte ; + : line-clear ( -- ) #! Call this in the line editor scope. - 0 caret set "" line-text set ; + 0 caret set + "" line-text set ; : ( -- editor ) - [ line-clear ] extend ; + [ + line-clear + 100 history set + 0 history-index set + ] extend ; : caret-insert ( str offset -- ) #! Call this in the line editor scope. @@ -51,6 +106,7 @@ SYMBOL: caret : line-insert ( str offset -- ) #! Call this in the line editor scope. + reset-history 2dup caret-insert line-text get swap str/ swapd cat3 line-text set ; @@ -73,6 +129,7 @@ SYMBOL: caret : line-remove ( offset length -- ) #! Call this in the line editor scope. + reset-history 2dup caret-remove dupd + line-text get str-tail >r line-text get str-head r> cat2 From 26f120adb8146c4d80775096a00400fb6ef37fef Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 Jan 2005 00:10:02 +0000 Subject: [PATCH 005/122] new assembler; wrote a new asm primitives --- TODO.FACTOR.txt | 4 +- factor/DefaultVocabularyLookup.java | 8 +- factor/ExternalFactor.java | 3 + factor/FactorMethodDefinition.java | 5 +- factor/FactorTraitsDefinition.java | 41 ---- factor/FactorWord.java | 19 +- factor/FactorWordDefinition.java | 62 ------ factor/jedit/FactorAsset.java | 1 - factor/jedit/FactorPlugin.props | 5 +- factor/jedit/FactorSideKickParser.java | 43 ++-- factor/jedit/FactorWordRenderer.java | 23 +- factor/parser/Defer.java | 50 ----- factor/parser/{Symbol.java => Definer.java} | 14 +- factor/parser/Generic.java | 48 ---- factor/parser/Ine.java | 7 +- library/bootstrap/boot-stage2.factor | 5 +- library/compiler/assembly-x86.factor | 229 -------------------- library/compiler/compiler.factor | 6 + library/compiler/generator-x86.factor | 175 --------------- library/compiler/simplifier.factor | 5 +- library/compiler/x86/fixnum.factor | 113 ++++++++++ library/test/benchmark/fib.factor | 11 + library/test/compiler/asm-test.factor | 46 ---- library/test/compiler/generic.factor | 6 +- library/test/compiler/stack.factor | 26 ++- 25 files changed, 224 insertions(+), 731 deletions(-) delete mode 100644 factor/FactorTraitsDefinition.java delete mode 100644 factor/FactorWordDefinition.java delete mode 100644 factor/parser/Defer.java rename factor/parser/{Symbol.java => Definer.java} (82%) delete mode 100644 factor/parser/Generic.java delete mode 100644 library/compiler/assembly-x86.factor delete mode 100644 library/compiler/generator-x86.factor create mode 100644 library/compiler/x86/fixnum.factor delete mode 100644 library/test/compiler/asm-test.factor diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 5c06251c60..3586470651 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,8 +1,9 @@ + compiler: +- type inference fails with some assembler words - optimize away dispatch - getenv/setenv: if literal arg, compile as a load/store -- assembler opcodes dispatch on operand types +- update compiler for new assembler + oop: @@ -33,6 +34,7 @@ + kernel: +- ppc register decls - do partial objects cause problems? - better i/o scheduler - remove sbufs diff --git a/factor/DefaultVocabularyLookup.java b/factor/DefaultVocabularyLookup.java index 4e0a3d3f6b..88a7bee609 100644 --- a/factor/DefaultVocabularyLookup.java +++ b/factor/DefaultVocabularyLookup.java @@ -91,7 +91,7 @@ public class DefaultVocabularyLookup implements VocabularyLookup FactorWord ine = define("syntax",";"); ine.parsing = new Ine(def,ine); FactorWord symbol = define("syntax","SYMBOL:"); - symbol.parsing = new Symbol(symbol); + symbol.parsing = new Definer(symbol); /* reading numbers with another base */ FactorWord bin = define("syntax","BIN:"); @@ -105,7 +105,7 @@ public class DefaultVocabularyLookup implements VocabularyLookup FactorWord noParsing = define("syntax","POSTPONE:"); noParsing.parsing = new NoParsing(noParsing); FactorWord defer = define("syntax","DEFER:"); - defer.parsing = new Defer(defer); + defer.parsing = new Definer(defer); FactorWord in = define("syntax","IN:"); in.parsing = new In(in); FactorWord use = define("syntax","USE:"); @@ -116,9 +116,9 @@ public class DefaultVocabularyLookup implements VocabularyLookup /* OOP */ FactorWord generic = define("generic","GENERIC:"); - generic.parsing = new Generic(generic); + generic.parsing = new Definer(generic); FactorWord traits = define("generic","TRAITS:"); - traits.parsing = new Traits(traits); + traits.parsing = new Definer(traits); FactorWord beginMethod = define("generic","M:"); beginMethod.parsing = new BeginMethod(beginMethod,def); FactorWord beginConstructor = define("generic","C:"); diff --git a/factor/ExternalFactor.java b/factor/ExternalFactor.java index ec969e9f64..09222d3161 100644 --- a/factor/ExternalFactor.java +++ b/factor/ExternalFactor.java @@ -123,6 +123,9 @@ public class ExternalFactor extends DefaultVocabularyLookup */ public synchronized String eval(String cmd) throws IOException { + if(isClosed) + throw new IOException("ExternalFactor stream closed"); + try { waitForAck(); diff --git a/factor/FactorMethodDefinition.java b/factor/FactorMethodDefinition.java index 440b03416e..18318eaa65 100644 --- a/factor/FactorMethodDefinition.java +++ b/factor/FactorMethodDefinition.java @@ -32,15 +32,16 @@ package factor; /** * M: type generic ... ;M */ -public class FactorMethodDefinition extends FactorWordDefinition +public class FactorMethodDefinition { private FactorWord type; + private FactorWord generic; private Cons def; public FactorMethodDefinition(FactorWord type, FactorWord generic, Cons def) { - super(generic); + this.generic = generic; this.type = type; this.def = def; } diff --git a/factor/FactorTraitsDefinition.java b/factor/FactorTraitsDefinition.java deleted file mode 100644 index 3fdbf43bc5..0000000000 --- a/factor/FactorTraitsDefinition.java +++ /dev/null @@ -1,41 +0,0 @@ -/* :folding=explicit:collapseFolds=1: */ - -/* -* $Id$ -* -* Copyright (C) 2004 Slava Pestov. -* -* Redistribution and use in source and binary forms, with or without -* modification, are permitted provided that the following conditions are met: -* -* 1. Redistributions of source code must retain the above copyright notice, -* this list of conditions and the following disclaimer. -* -* 2. Redistributions in binary form must reproduce the above copyright notice, -* this list of conditions and the following disclaimer in the documentation -* and/or other materials provided with the distribution. -* -* THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -* INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -* FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -* DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -* OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -* OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -* ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*/ - -package factor; - -/** - * TRAITS: type - */ -public class FactorTraitsDefinition extends FactorSymbolDefinition -{ - public FactorTraitsDefinition(FactorWord word) - { - super(word,word); - } -} diff --git a/factor/FactorWord.java b/factor/FactorWord.java index 21803c4a95..2186683111 100644 --- a/factor/FactorWord.java +++ b/factor/FactorWord.java @@ -42,9 +42,9 @@ public class FactorWord implements FactorExternalizable public FactorParsingDefinition parsing; /** - * Stub for interpreter definition. + * For browsing, the parsing word that was used to define this word. */ - public FactorWordDefinition def; + private FactorWord definer; /** * Should the parser keep doc comments? @@ -70,4 +70,19 @@ public class FactorWord implements FactorExternalizable { return name == null ? "#" : name; } //}}} + + //{{{ getDefiner() method + public FactorWord getDefiner() + { + if(definer == null) + return new FactorWord(null,"DEFER:"); + else + return definer; + } //}}} + + //{{{ setDefiner() method + public void setDefiner(FactorWord definer) + { + this.definer = definer; + } //}}} } diff --git a/factor/FactorWordDefinition.java b/factor/FactorWordDefinition.java deleted file mode 100644 index 2c4ee3f155..0000000000 --- a/factor/FactorWordDefinition.java +++ /dev/null @@ -1,62 +0,0 @@ -/* :folding=explicit:collapseFolds=1: */ - -/* - * $Id$ - * - * Copyright (C) 2003, 2004 Slava Pestov. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * 1. Redistributions of source code must retain the above copyright notice, - * this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND - * FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE - * DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; - * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, - * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR - * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF - * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - */ - -package factor; - -import java.io.*; -import java.util.*; - -/** - * A word definition. - */ -public abstract class FactorWordDefinition -{ - public FactorWord word; - - //{{{ FactorWordDefinition constructor - /** - * A new definition. - */ - public FactorWordDefinition(FactorWord word) - { - this.word = word; - } //}}} - - //{{{ toList() method - public Cons toList() - { - return null; - } //}}} - - //{{{ toString() method - public String toString() - { - return getClass().getName() + ": " + word; - } //}}} -} diff --git a/factor/jedit/FactorAsset.java b/factor/jedit/FactorAsset.java index 934f1107c9..d426c9d441 100644 --- a/factor/jedit/FactorAsset.java +++ b/factor/jedit/FactorAsset.java @@ -30,7 +30,6 @@ package factor.jedit; import factor.FactorWord; -import factor.FactorWordDefinition; import javax.swing.Icon; import javax.swing.text.Position; import org.gjt.sp.jedit.Buffer; diff --git a/factor/jedit/FactorPlugin.props b/factor/jedit/FactorPlugin.props index 811bb4557f..85dba2b6b0 100644 --- a/factor/jedit/FactorPlugin.props +++ b/factor/jedit/FactorPlugin.props @@ -48,10 +48,7 @@ sidekick.parser.factor.label=Factor mode.factor.sidekick.parser=factor factor.completion.in=IN: {0}\ -factor.completion.colon=: {0} -factor.completion.defer=DEFER: {0} -factor.completion.parsing=PARSING: {0} -factor.completion.symbol=SYMBOL: {0} +factor.completion.def={0} {1} factor.completion.stack={0} ( {1}) # Dialog boxes diff --git a/factor/jedit/FactorSideKickParser.java b/factor/jedit/FactorSideKickParser.java index 68e123d30a..6c3649d572 100644 --- a/factor/jedit/FactorSideKickParser.java +++ b/factor/jedit/FactorSideKickParser.java @@ -130,12 +130,12 @@ public class FactorSideKickParser extends SideKickParser errorSource); r = new FactorReader(scanner,false,FactorPlugin.getExternalInstance()); - Cons parsed = r.parse(); + r.parse(); d.in = r.getIn(); d.use = r.getUse(); - addWordDefNodes(d,parsed,buffer); + addWordDefNodes(d,r.getDefinedWords(),buffer); } catch(FactorParseException pe) { @@ -172,38 +172,31 @@ public class FactorSideKickParser extends SideKickParser } //}}} //{{{ addWordDefNodes() method - private void addWordDefNodes(FactorParsedData d, Cons parsed, Buffer buffer) + private void addWordDefNodes(FactorParsedData d, Cons words, Buffer buffer) { FactorAsset last = null; - while(parsed != null) + while(words != null) { - if(parsed.car instanceof FactorWordDefinition) - { - FactorWordDefinition def - = (FactorWordDefinition) - parsed.car; + FactorWord word = (FactorWord)words.car; - FactorWord word = def.word; + /* word lines are indexed from 1 */ + int startLine = Math.max(0,Math.min( + buffer.getLineCount() - 1, + word.line - 1)); + int startLineLength = buffer.getLineLength(startLine); + int startCol = Math.min(word.col,startLineLength); - /* word lines are indexed from 1 */ - int startLine = Math.max(0,Math.min( - buffer.getLineCount() - 1, - word.line - 1)); - int startLineLength = buffer.getLineLength(startLine); - int startCol = Math.min(word.col,startLineLength); + int start = buffer.getLineStartOffset(startLine) + + startCol; - int start = buffer.getLineStartOffset(startLine) - + startCol; + if(last != null) + last.end = buffer.createPosition(Math.max(0,start - 1)); - if(last != null) - last.end = buffer.createPosition(Math.max(0,start - 1)); + last = new FactorAsset(word,buffer.createPosition(start)); + d.root.add(new DefaultMutableTreeNode(last)); - last = new FactorAsset(word,buffer.createPosition(start)); - d.root.add(new DefaultMutableTreeNode(last)); - } - - parsed = parsed.next(); + words = words.next(); } if(last != null) diff --git a/factor/jedit/FactorWordRenderer.java b/factor/jedit/FactorWordRenderer.java index 08a6fefaf6..948ca27cb0 100644 --- a/factor/jedit/FactorWordRenderer.java +++ b/factor/jedit/FactorWordRenderer.java @@ -39,19 +39,12 @@ public class FactorWordRenderer extends DefaultListCellRenderer //{{{ getWordHTMLString() method public static String getWordHTMLString(FactorWord word, boolean showIn) { - String prop = "factor.completion.colon"; - - /* if(def == null) - { - if(word.parsing != null) - prop = "factor.completion.parsing"; - else - prop = "factor.completion.defer"; - } - else if(def instanceof FactorSymbolDefinition) - { - prop = "factor.completion.symbol"; - } */ + String defStr = jEdit.getProperty( + "factor.completion.def", + new String[] { + MiscUtilities.charsToEntities(word.getDefiner().name), + MiscUtilities.charsToEntities(word.name) + }); String in; if(showIn) @@ -64,8 +57,8 @@ public class FactorWordRenderer extends DefaultListCellRenderer else in = ""; - String html = "" + in + jEdit.getProperty(prop, - new Object[] { MiscUtilities.charsToEntities(word.name) }); + String html = "" + in + defStr; + if(word.stackEffect != null) { html = jEdit.getProperty("factor.completion.stack", diff --git a/factor/parser/Defer.java b/factor/parser/Defer.java deleted file mode 100644 index 46418d603b..0000000000 --- a/factor/parser/Defer.java +++ /dev/null @@ -1,50 +0,0 @@ -/* :folding=explicit:collapseFolds=1: */ - -/* - * $Id$ - * - * Copyright (C) 2004 Slava Pestov. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * 1. Redistributions of source code must retain the above copyright notice, - * this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND - * FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE - * DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; - * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, - * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR - * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF - * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - */ - -package factor.parser; - -import factor.*; - -public class Defer extends FactorParsingDefinition -{ - //{{{ Defer constructor - /** - * A new definition. - */ - public Defer(FactorWord word) - { - super(word); - } //}}} - - public void eval(FactorReader reader) - throws Exception - { - reader.nextWord(true); - } -} diff --git a/factor/parser/Symbol.java b/factor/parser/Definer.java similarity index 82% rename from factor/parser/Symbol.java rename to factor/parser/Definer.java index 000d290106..f2ac09b71e 100644 --- a/factor/parser/Symbol.java +++ b/factor/parser/Definer.java @@ -31,9 +31,13 @@ package factor.parser; import factor.*; -public class Symbol extends FactorParsingDefinition +/** + * A definer where the word name to be defined follows the parsing word. + * Eg, DEFER: SYMBOL: GENERIC: etc. + */ +public class Definer extends FactorParsingDefinition { - public Symbol(FactorWord word) + public Definer(FactorWord word) { super(word); } @@ -42,7 +46,9 @@ public class Symbol extends FactorParsingDefinition throws Exception { FactorWord w = reader.nextWord(true); - w.def = new FactorSymbolDefinition(w,w); - reader.append(w.def); + /* Only ever null with restartable scanner; + error already logged, so give up */ + if(w != null) + w.setDefiner(word); } } diff --git a/factor/parser/Generic.java b/factor/parser/Generic.java deleted file mode 100644 index 6886b9675a..0000000000 --- a/factor/parser/Generic.java +++ /dev/null @@ -1,48 +0,0 @@ -/* :folding=explicit:collapseFolds=1: */ - -/* - * $Id$ - * - * Copyright (C) 2004 Slava Pestov. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * 1. Redistributions of source code must retain the above copyright notice, - * this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND - * FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE - * DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; - * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, - * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR - * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF - * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - */ - -package factor.parser; - -import factor.*; - -public class Generic extends FactorParsingDefinition -{ - public Generic(FactorWord word) - { - super(word); - } - - public void eval(FactorReader reader) - throws Exception - { - FactorWord w = reader.nextWord(true); - w.def = new FactorGenericDefinition(w); - reader.append(w.def); - } -} diff --git a/factor/parser/Ine.java b/factor/parser/Ine.java index 24c6500549..e729053eda 100644 --- a/factor/parser/Ine.java +++ b/factor/parser/Ine.java @@ -48,10 +48,7 @@ public class Ine extends FactorParsingDefinition FactorWord w = state.defining; /* Only ever null with restartable scanner; error already logged, so give up */ - if(w == null) - return; - - w.def = new FactorCompoundDefinition(w,state.first); - reader.append(w.def); + if(w != null) + w.setDefiner(start); } } diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index 9d1ddb8729..1410487c58 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -181,8 +181,9 @@ os "win32" = [ cpu "x86" = [ [ - "/library/compiler/assembly-x86.factor" - "/library/compiler/generator-x86.factor" + "/library/compiler/x86/assembler.factor" + "/library/compiler/x86/generator.factor" + "/library/compiler/x86/fixnum.factor" ] [ dup print run-resource diff --git a/library/compiler/assembly-x86.factor b/library/compiler/assembly-x86.factor deleted file mode 100644 index c74a973a6f..0000000000 --- a/library/compiler/assembly-x86.factor +++ /dev/null @@ -1,229 +0,0 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -IN: compiler -USE: kernel -USE: compiler -USE: math - -: EAX 0 ; -: ECX 1 ; -: EDX 2 ; -: EBX 3 ; -: ESP 4 ; -: EBP 5 ; -: ESI 6 ; -: EDI 7 ; - -: byte? -128 127 between? ; - -: eax/other ( reg quot quot -- ) - #! Execute first quotation if reg is EAX, second quotation - #! otherwise, leaving reg on the stack. - pick EAX = [ drop nip call ] [ nip call ] ifte ; inline - -: byte/eax/cell ( imm reg byte eax cell -- ) - #! Assemble an instruction with 3 forms; byte operand, any - #! register; eax register, cell operand; other register, - #! cell operand. - >r >r >r >r dup byte? [ - r> r> call r> drop r> drop compile-byte - ] [ - r> dup EAX = [ - drop r> drop r> call r> drop compile-cell - ] [ - r> drop r> drop r> call compile-cell - ] ifte - ] ifte ; inline - -: MOD-R/M ( r/m reg/opcode mod -- ) - #! MOD-R/M is MOD REG/OPCODE R/M - 6 shift swap 3 shift bitor bitor compile-byte ; - -: PUSH-R ( reg -- ) - HEX: 50 + compile-byte ; - -: PUSH-[R] ( reg -- ) - HEX: ff compile-byte BIN: 110 0 MOD-R/M ; - -: PUSH-I ( imm -- ) - HEX: 68 compile-byte compile-cell ; - -: PUSH-I/PARTIAL ( -- fixup ) - #! This is potentially bad. In the compilation of - #! #return-to, we need to push something which is - #! only known later. - #! - #! Returns address of 32-bit immediate. - HEX: 68 compile-byte compiled-offset 0 compile-cell ; - -: POP-R ( reg -- ) - HEX: 58 + compile-byte ; - -: LEAVE ( -- ) - HEX: c9 compile-byte ; - -: I>R ( imm reg -- ) - #! MOV TO - HEX: b8 + compile-byte compile-cell ; - -: [I]>R ( imm reg -- ) - #! MOV INDIRECT TO - [ - HEX: a1 compile-byte - ] [ - HEX: 8b compile-byte - BIN: 101 swap 0 MOD-R/M - ] eax/other compile-cell ; - -: I>[R] ( imm reg -- ) - #! MOV TO INDIRECT - HEX: c7 compile-byte compile-byte compile-cell ; - -: R>[I] ( reg imm -- ) - #! MOV TO INDIRECT . - swap [ - HEX: a3 compile-byte - ] [ - HEX: 89 compile-byte - BIN: 101 swap 0 MOD-R/M - ] eax/other compile-cell ; - -: R>R ( reg reg -- ) - #! MOV TO . - HEX: 89 compile-byte swap BIN: 11 MOD-R/M ; - -: [R]>R ( reg reg -- ) - #! MOV INDIRECT TO . - HEX: 8b compile-byte 0 MOD-R/M ; - -: D[R]>R ( disp reg reg -- ) - #! MOV INDIRECT DISPLACED TO . - HEX: 8b compile-byte 1 MOD-R/M compile-byte ; - -: R>[R] ( reg reg -- ) - #! MOV TO INDIRECT . - HEX: 89 compile-byte swap 0 MOD-R/M ; - -: I+[I] ( imm addr -- ) - #! ADD TO ADDRESS - HEX: 81 compile-byte - BIN: 101 0 0 MOD-R/M - compile-cell - compile-cell ; - -: EAX+/PARTIAL ( -- fixup ) - #! This is potentially bad. In the compilation of - #! generic and 2generic, we need to add something which is - #! only known later. - #! - #! Returns address of 32-bit immediate. - HEX: 05 compile-byte compiled-offset 0 compile-cell ; - -: R+I ( imm reg -- ) - #! ADD TO , STORE RESULT IN - [ - HEX: 83 compile-byte - 0 BIN: 11 MOD-R/M - ] [ - HEX: 05 compile-byte - ] [ - HEX: 81 compile-byte - 0 BIN: 11 MOD-R/M - ] byte/eax/cell ; - -: R-I ( imm reg -- ) - #! SUBTRACT FROM , STORE RESULT IN - [ - HEX: 83 compile-byte - BIN: 101 BIN: 11 MOD-R/M - ] [ - HEX: 2d compile-byte - ] [ - HEX: 81 compile-byte - BIN: 101 BIN: 11 MOD-R/M - ] byte/eax/cell ; - -: R< BY , STORE RESULT IN - HEX: c1 compile-byte - BIN: 100 BIN: 11 MOD-R/M - compile-byte ; - -: R>>I ( imm reg -- ) - #! SHIFT BY , STORE RESULT IN - HEX: c1 compile-byte - BIN: 111 BIN: 11 MOD-R/M - compile-byte ; - -: CMP-I-R ( imm reg -- ) - #! There are three forms of CMP we assemble - #! 83 f8 03 cmpl $0x3,%eax - #! 81 fa 33 33 33 00 cmpl $0x333333,%edx - #! 3d 33 33 33 00 cmpl $0x333333,%eax - [ - HEX: 83 compile-byte - BIN: 111 BIN: 11 MOD-R/M - ] [ - HEX: 3d compile-byte - ] [ - HEX: 81 compile-byte - BIN: 111 BIN: 11 MOD-R/M - ] byte/eax/cell ; - -: JUMP-FIXUP ( addr where -- ) - #! Encode a relative offset to addr from where at where. - #! Add 4 because addr is relative to *after* insn. - dup >r 4 + - r> set-compiled-cell ; - -: (JUMP) ( xt -- fixup ) - #! addr is relative to *after* insn - compiled-offset 0 compile-cell ; - -: JUMP ( -- fixup ) - #! Push address of branch for fixup - HEX: e9 compile-byte (JUMP) ; - -: JUMP-[R] ( reg -- ) - #! JUMP TO INDIRECT . - HEX: ff compile-byte BIN: 100 0 MOD-R/M ; - -: CALL ( -- fixup ) - HEX: e8 compile-byte (JUMP) ; - -: CALL-[R] ( reg -- ) - #! CALL INDIRECT . - HEX: ff compile-byte BIN: 10 0 MOD-R/M ; - -: JE ( -- fixup ) - HEX: 0f compile-byte HEX: 84 compile-byte (JUMP) ; - -: JNE ( -- fixup ) - HEX: 0f compile-byte HEX: 85 compile-byte (JUMP) ; - -: RET ( -- ) - HEX: c3 compile-byte ; diff --git a/library/compiler/compiler.factor b/library/compiler/compiler.factor index 66b245e222..999c1fb5bd 100644 --- a/library/compiler/compiler.factor +++ b/library/compiler/compiler.factor @@ -102,3 +102,9 @@ M: compound (compile) ( word -- ) ] [ "Unsupported CPU" print ] ifte ; + +: decompile ( word -- ) + [ word-primitive ] keep set-word-primitive ; + +: recompile ( word -- ) + dup decompile compile ; diff --git a/library/compiler/generator-x86.factor b/library/compiler/generator-x86.factor deleted file mode 100644 index 22712c3708..0000000000 --- a/library/compiler/generator-x86.factor +++ /dev/null @@ -1,175 +0,0 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -IN: compiler -USE: alien -USE: inference -USE: kernel -USE: namespaces -USE: words -USE: lists -USE: math - -: DS ( -- address ) "ds" f dlsym ; - -: absolute-ds ( -- ) - #! Add an entry to the relocation table for the 32-bit - #! immediate just compiled. - "ds" f f rel-dlsym ; - -: PEEK-DS ( -- ) - #! Peek datastack to EAX. - DS ECX [I]>R absolute-ds - ECX EAX [R]>R ; - -: POP-DS ( -- ) - #! Pop datastack to EAX. - PEEK-DS - 4 ECX R-I - ECX DS R>[I] absolute-ds ; - -#push-immediate [ - DS ECX [I]>R absolute-ds - 4 ECX R+I - address ECX I>[R] - ECX DS R>[I] absolute-ds -] "generator" set-word-property - -#push-indirect [ - DS ECX [I]>R absolute-ds - 4 ECX R+I - intern-literal EAX [I]>R rel-address - EAX ECX R>[R] - ECX DS R>[I] absolute-ds -] "generator" set-word-property - -#replace-immediate [ - DS ECX [I]>R absolute-ds - address ECX I>[R] - ECX DS R>[I] absolute-ds -] "generator" set-word-property - -#replace-indirect [ - DS ECX [I]>R absolute-ds - intern-literal EAX [I]>R rel-address - EAX ECX R>[R] - ECX DS R>[I] absolute-ds -] "generator" set-word-property - -#slot [ - PEEK-DS - 2unlist type-tag >r cell * r> - EAX EAX D[R]>R - DS ECX [I]>R absolute-ds - EAX ECX R>[R] -] "generator" set-word-property - -#call [ - dup dup postpone-word - CALL compiled-offset defer-xt - t rel-word -] "generator" set-word-property - -#jump [ - dup dup postpone-word - JUMP compiled-offset defer-xt - t rel-word -] "generator" set-word-property - -#call-label [ - CALL compiled-offset defer-xt -] "generator" set-word-property - -#jump-label [ - JUMP compiled-offset defer-xt -] "generator" set-word-property - -#jump-t [ - POP-DS - ! condition is now in EAX - f address EAX CMP-I-R - ! jump w/ address added later - JNE compiled-offset defer-xt -] "generator" set-word-property - -#return-to [ - PUSH-I/PARTIAL 0 defer-xt rel-address -] "generator" set-word-property - -#return [ drop RET ] "generator" set-word-property - -#dispatch [ - #! Compile a piece of code that jumps to an offset in a - #! jump table indexed by the fixnum at the top of the stack. - #! The jump table must immediately follow this macro. - drop - POP-DS - 1 EAX R>>I - EAX+/PARTIAL ( -- fixup ) rel-address - EAX JUMP-[R] - compile-aligned - compiled-offset swap set-compiled-cell ( fixup -- ) -] "generator" set-word-property - -#target [ - #! Jump table entries are absolute addresses. - compiled-offset 0 compile-cell 0 defer-xt rel-address -] "generator" set-word-property - -#c-call [ - uncons load-dll 2dup dlsym CALL JUMP-FIXUP t rel-dlsym -] "generator" set-word-property - -#unbox [ - dup f dlsym CALL JUMP-FIXUP f t rel-dlsym - EAX PUSH-R -] "generator" set-word-property - -#box [ - EAX PUSH-R - dup f dlsym CALL JUMP-FIXUP f t rel-dlsym - 4 ESP R+I -] "generator" set-word-property - -#cleanup [ - dup 0 = [ drop ] [ ESP R+I ] ifte -] "generator" set-word-property - -[ - [ #drop drop ] - [ #dup dup ] - [ #swap swap ] - [ #over over ] - [ #pick pick ] - [ #>r >r ] - [ #r> r> ] -] [ - uncons - [ - car dup CALL compiled-offset defer-xt t rel-word drop - ] cons - "generator" set-word-property -] each diff --git a/library/compiler/simplifier.factor b/library/compiler/simplifier.factor index a531e64445..50673797b7 100644 --- a/library/compiler/simplifier.factor +++ b/library/compiler/simplifier.factor @@ -42,9 +42,6 @@ USE: unparser USE: vectors USE: words -! peephole? -! "whose peephole are we optimizing" "your mom's" - : labels ( linear -- list ) #! Make a list of all labels defined in the linear IR. [ [ unswons #label = [ , ] [ drop ] ifte ] each ] make-list ; @@ -80,7 +77,7 @@ USE: words dup [ uncons simplify-node drop (simplify) ] [ drop ] ifte ; : simplify ( linear -- linear ) - purge-labels [ (simplify) ] make-list ; + ( purge-labels ) [ (simplify) ] make-list ; : follow ( linear -- linear ) dup car car "follow" [ ] singleton ; diff --git a/library/compiler/x86/fixnum.factor b/library/compiler/x86/fixnum.factor new file mode 100644 index 0000000000..0928412892 --- /dev/null +++ b/library/compiler/x86/fixnum.factor @@ -0,0 +1,113 @@ +! :folding=indent:collapseFolds=1: + +! $Id$ +! +! Copyright (C) 2004 Slava Pestov. +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, +! this list of conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, +! this list of conditions and the following disclaimer in the documentation +! and/or other materials provided with the distribution. +! +! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, +! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; +! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +USE: compiler +IN: math-internals +USE: assembler +USE: inference +USE: math +USE: words +USE: kernel +USE: alien +USE: lists + +! This file provides compiling definitions for fixnum words +! that are faster than what C gives us. + +#drop [ + drop + ECX DS> + ECX 4 SUB + ECX >DS +] "generator" set-word-property + +#dup [ + drop + ECX DS> + EAX [ ECX ] MOV + ECX 4 ADD + [ ECX ] EAX MOV + ECX >DS +] "generator" set-word-property + +#swap [ + drop + ECX DS> + EAX [ ECX ] MOV + EDX [ ECX -4 ] MOV + [ ECX ] EDX MOV + [ ECX -4 ] EAX MOV +] "generator" set-word-property + +#over [ + drop + ECX DS> + EAX [ ECX -4 ] MOV + ECX 4 ADD + [ ECX ] EAX MOV + ECX >DS +] "generator" set-word-property + +#pick [ + drop + ECX DS> + EAX [ ECX -8 ] MOV + ECX 4 ADD + [ ECX ] EAX MOV + ECX >DS +] "generator" set-word-property + +\ #dup f "linearize" set-word-property + +: self ( word -- ) + f swap dup "infer-effect" word-property (consume/produce) ; + +\ fixnum- [ \ fixnum- self ] "infer" set-word-property + +\ fixnum+ [ \ fixnum+ self ] "infer" set-word-property + +: fixnum-insn ( overflow opcode -- ) + #! This needs to be factored. + ECX DS> + EAX [ ECX -4 ] MOV + EAX [ ECX ] rot execute + 0 JNO fixup + swap compile-call + 0 JMP fixup >r + compiled-offset swap patch + ECX 4 SUB + [ ECX ] EAX MOV + ECX >DS + r> compiled-offset swap patch ; + +\ fixnum+ [ + drop \ fixnum+ \ ADD fixnum-insn +] "generator" set-word-property + +\ fixnum- [ + drop \ fixnum- \ SUB fixnum-insn +] "generator" set-word-property diff --git a/library/test/benchmark/fib.factor b/library/test/benchmark/fib.factor index 48cfede1ca..8abc9cf52f 100644 --- a/library/test/benchmark/fib.factor +++ b/library/test/benchmark/fib.factor @@ -3,6 +3,17 @@ USE: compiler USE: kernel USE: math USE: test +USE: math-internals + +: fixnum-fib ( n -- nth fibonacci number ) + dup 1 fixnum<= [ + drop 1 + ] [ + 1 fixnum- dup fixnum-fib swap 1 fixnum- fixnum-fib fixnum+ + ] ifte ; + compiled + +[ 9227465 ] [ 34 fixnum-fib ] unit-test : fib ( n -- nth fibonacci number ) dup 1 <= [ drop 1 ] [ 1 - dup fib swap 1 - fib + ] ifte ; diff --git a/library/test/compiler/asm-test.factor b/library/test/compiler/asm-test.factor deleted file mode 100644 index f83648cfc0..0000000000 --- a/library/test/compiler/asm-test.factor +++ /dev/null @@ -1,46 +0,0 @@ -IN: scratchpad -USE: compiler - -0 EAX I>R -0 ECX I>R - -0 EAX [I]>R -0 ECX [I]>R - -0 EAX I>[R] -0 ECX I>[R] - -EAX 0 R>[I] -ECX 0 R>[I] - -EAX EAX [R]>R -EAX ECX [R]>R -ECX EAX [R]>R -ECX ECX [R]>R - -EAX EAX R>[R] -EAX ECX R>[R] -ECX EAX R>[R] -ECX ECX R>[R] - -4 0 I+[I] -0 4 I+[I] - -4 EAX R+I -4 ECX R+I -65535 EAX R+I -65535 ECX R+I - -4 EAX R-I -4 ECX R-I -65535 EAX R-I -65535 ECX R-I - -EAX PUSH-R -ECX PUSH-R -EAX PUSH-[R] -ECX PUSH-[R] -65535 PUSH-I - -EAX JUMP-[R] -ECX JUMP-[R] diff --git a/library/test/compiler/generic.factor b/library/test/compiler/generic.factor index ce84439b30..320d3a1016 100644 --- a/library/test/compiler/generic.factor +++ b/library/test/compiler/generic.factor @@ -73,10 +73,10 @@ USE: words [ drop ] [ drop ] [ drop ] - } single-combination + ; compiled + } single-combination ; compiled -[ 5 ] [ 2 3 4 single-combination-test-alt ] unit-test -[ 7/2 ] [ 2 3 3/2 single-combination-test-alt ] unit-test +[ 5 ] [ 2 3 4 single-combination-test-alt + ] unit-test +[ 7/2 ] [ 2 3 3/2 single-combination-test-alt + ] unit-test DEFER: single-combination-test-2 diff --git a/library/test/compiler/stack.factor b/library/test/compiler/stack.factor index af6f937192..5e907b277f 100644 --- a/library/test/compiler/stack.factor +++ b/library/test/compiler/stack.factor @@ -7,16 +7,26 @@ USE: math USE: kernel ! Make sure that stack ops compile to correct code. -: compile-call ( quot -- word ) +: compile-1 ( quot -- word ) gensym [ swap define-compound ] keep dup compile execute ; -[ ] [ 1 [ drop ] compile-call ] unit-test -[ ] [ [ 1 drop ] compile-call ] unit-test -[ ] [ [ 1 2 2drop ] compile-call ] unit-test -[ ] [ 1 [ 2 2drop ] compile-call ] unit-test -[ ] [ 1 2 [ 2drop ] compile-call ] unit-test -[ 1 1 ] [ 1 [ dup ] compile-call ] unit-test -[ 1 1 ] [ [ 1 dup ] compile-call ] unit-test +[ ] [ 1 [ drop ] compile-1 ] unit-test +[ ] [ [ 1 drop ] compile-1 ] unit-test +[ ] [ [ 1 2 2drop ] compile-1 ] unit-test +[ ] [ 1 [ 2 2drop ] compile-1 ] unit-test +[ ] [ 1 2 [ 2drop ] compile-1 ] unit-test +[ 2 1 ] [ [ 1 2 swap ] compile-1 ] unit-test +[ 2 1 ] [ 1 [ 2 swap ] compile-1 ] unit-test +[ 2 1 ] [ 1 2 [ swap ] compile-1 ] unit-test +[ 1 1 ] [ 1 [ dup ] compile-1 ] unit-test +[ 1 1 ] [ [ 1 dup ] compile-1 ] unit-test +[ 1 2 1 ] [ [ 1 2 over ] compile-1 ] unit-test +[ 1 2 1 ] [ 1 [ 2 over ] compile-1 ] unit-test +[ 1 2 1 ] [ 1 2 [ over ] compile-1 ] unit-test +[ 1 2 3 1 ] [ [ 1 2 3 pick ] compile-1 ] unit-test +[ 1 2 3 1 ] [ 1 [ 2 3 pick ] compile-1 ] unit-test +[ 1 2 3 1 ] [ 1 2 [ 3 pick ] compile-1 ] unit-test +[ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-1 ] unit-test ! Test various kill combinations From a488ffbd11dfabc125ed40866cef40736d503383 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 Jan 2005 02:42:07 +0000 Subject: [PATCH 006/122] x86 backend code cleanups --- library/bootstrap/boot-stage2.factor | 1 + library/bootstrap/primitives.factor | 8 +- library/compiler/alien-types.factor | 1 + library/compiler/alien.factor | 1 + library/compiler/assembler.factor | 2 +- library/compiler/generator.factor | 1 + library/compiler/optimizer.factor | 40 ++-- library/compiler/simplifier.factor | 2 +- library/compiler/x86/fixnum.factor | 51 +--- library/compiler/x86/stack.factor | 167 +++++++++++++ library/compiler/xt.factor | 1 + library/inference/dataflow.factor | 14 +- library/inference/stack.factor | 28 +-- library/inference/types.factor | 7 +- library/primitives.factor | 345 ++++++++++++++------------- 15 files changed, 389 insertions(+), 280 deletions(-) create mode 100644 library/compiler/x86/stack.factor diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index 1410487c58..0eb5df43ff 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -182,6 +182,7 @@ os "win32" = [ cpu "x86" = [ [ "/library/compiler/x86/assembler.factor" + "/library/compiler/x86/stack.factor" "/library/compiler/x86/generator.factor" "/library/compiler/x86/fixnum.factor" ] [ diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor index 6dd9d8c763..05020fef34 100644 --- a/library/bootstrap/primitives.factor +++ b/library/bootstrap/primitives.factor @@ -192,10 +192,10 @@ vocabularies get [ [ "kernel" | "type" ] [ "files" | "cwd" ] [ "files" | "cd" ] - [ "compiler" | "compiled-offset" ] - [ "compiler" | "set-compiled-offset" ] - [ "compiler" | "literal-top" ] - [ "compiler" | "set-literal-top" ] + [ "assembler" | "compiled-offset" ] + [ "assembler" | "set-compiled-offset" ] + [ "assembler" | "literal-top" ] + [ "assembler" | "set-literal-top" ] [ "kernel" | "address" ] [ "alien" | "dlopen" ] [ "alien" | "dlsym" ] diff --git a/library/compiler/alien-types.factor b/library/compiler/alien-types.factor index 3aae8cf27b..2bdf5d8f53 100644 --- a/library/compiler/alien-types.factor +++ b/library/compiler/alien-types.factor @@ -26,6 +26,7 @@ ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. IN: alien +USE: assembler USE: compiler USE: errors USE: hashtables diff --git a/library/compiler/alien.factor b/library/compiler/alien.factor index 4e43285945..7b99e0343e 100644 --- a/library/compiler/alien.factor +++ b/library/compiler/alien.factor @@ -26,6 +26,7 @@ ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. IN: alien +USE: assembler USE: compiler USE: errors USE: generic diff --git a/library/compiler/assembler.factor b/library/compiler/assembler.factor index f279a60400..83e65b299a 100644 --- a/library/compiler/assembler.factor +++ b/library/compiler/assembler.factor @@ -25,7 +25,7 @@ ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -IN: compiler +IN: assembler USE: alien USE: math USE: kernel diff --git a/library/compiler/generator.factor b/library/compiler/generator.factor index 644f6171c5..60b41c8948 100644 --- a/library/compiler/generator.factor +++ b/library/compiler/generator.factor @@ -26,6 +26,7 @@ ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. IN: compiler +USE: assembler USE: inference USE: errors USE: kernel diff --git a/library/compiler/optimizer.factor b/library/compiler/optimizer.factor index 7c196f2b38..349c9d76cb 100644 --- a/library/compiler/optimizer.factor +++ b/library/compiler/optimizer.factor @@ -180,12 +180,12 @@ USE: prettyprint ! Don't care about inputs to recursive combinator calls #call-label [ 2drop t ] "can-kill" set-word-property -#drop [ 2drop t ] "can-kill" set-word-property -#drop [ kill-node ] "kill-node" set-word-property -#dup [ 2drop t ] "can-kill" set-word-property -#dup [ kill-node ] "kill-node" set-word-property -#swap [ 2drop t ] "can-kill" set-word-property -#swap [ kill-node ] "kill-node" set-word-property +\ drop [ 2drop t ] "can-kill" set-word-property +\ drop [ kill-node ] "kill-node" set-word-property +\ dup [ 2drop t ] "can-kill" set-word-property +\ dup [ kill-node ] "kill-node" set-word-property +\ swap [ 2drop t ] "can-kill" set-word-property +\ swap [ kill-node ] "kill-node" set-word-property : kill-mask ( killing inputs -- mask ) [ over [ over value= ] some? >boolean nip ] map nip ; @@ -199,25 +199,25 @@ USE: prettyprint ] keep over [ [ node-op set ] extend , ] [ 2drop ] ifte ; -#over [ 2drop t ] "can-kill" set-word-property -#over [ +\ over [ 2drop t ] "can-kill" set-word-property +\ over [ [ - [ [ f f ] | #over ] - [ [ f t ] | #dup ] + [ [ f f ] | over ] + [ [ f t ] | dup ] ] reduce-stack-op ] "kill-node" set-word-property -#pick [ 2drop t ] "can-kill" set-word-property -#pick [ +\ pick [ 2drop t ] "can-kill" set-word-property +\ pick [ [ - [ [ f f f ] | #pick ] - [ [ f f t ] | #over ] - [ [ f t f ] | #over ] - [ [ f t t ] | #dup ] + [ [ f f f ] | pick ] + [ [ f f t ] | over ] + [ [ f t f ] | over ] + [ [ f t t ] | dup ] ] reduce-stack-op ] "kill-node" set-word-property -#>r [ 2drop t ] "can-kill" set-word-property -#>r [ kill-node ] "kill-node" set-word-property -#r> [ 2drop t ] "can-kill" set-word-property -#r> [ kill-node ] "kill-node" set-word-property +\ >r [ 2drop t ] "can-kill" set-word-property +\ >r [ kill-node ] "kill-node" set-word-property +\ r> [ 2drop t ] "can-kill" set-word-property +\ r> [ kill-node ] "kill-node" set-word-property diff --git a/library/compiler/simplifier.factor b/library/compiler/simplifier.factor index 50673797b7..0db9947baf 100644 --- a/library/compiler/simplifier.factor +++ b/library/compiler/simplifier.factor @@ -123,4 +123,4 @@ M: push-next simplify-drop ( node rest -- rest ? ) [ #push-indirect | #replace-indirect ] ] assoc swons , r> t ; -#drop [ simplify-drop ] "simplify" set-word-property +\ drop [ simplify-drop ] "simplify" set-word-property diff --git a/library/compiler/x86/fixnum.factor b/library/compiler/x86/fixnum.factor index 0928412892..f7eafdc1e5 100644 --- a/library/compiler/x86/fixnum.factor +++ b/library/compiler/x86/fixnum.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2004 Slava Pestov. +! Copyright (C) 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -25,8 +25,7 @@ ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -USE: compiler -IN: math-internals +IN: compiler USE: assembler USE: inference USE: math @@ -34,55 +33,11 @@ USE: words USE: kernel USE: alien USE: lists +USE: math-internals ! This file provides compiling definitions for fixnum words ! that are faster than what C gives us. -#drop [ - drop - ECX DS> - ECX 4 SUB - ECX >DS -] "generator" set-word-property - -#dup [ - drop - ECX DS> - EAX [ ECX ] MOV - ECX 4 ADD - [ ECX ] EAX MOV - ECX >DS -] "generator" set-word-property - -#swap [ - drop - ECX DS> - EAX [ ECX ] MOV - EDX [ ECX -4 ] MOV - [ ECX ] EDX MOV - [ ECX -4 ] EAX MOV -] "generator" set-word-property - -#over [ - drop - ECX DS> - EAX [ ECX -4 ] MOV - ECX 4 ADD - [ ECX ] EAX MOV - ECX >DS -] "generator" set-word-property - -#pick [ - drop - ECX DS> - EAX [ ECX -8 ] MOV - ECX 4 ADD - [ ECX ] EAX MOV - ECX >DS -] "generator" set-word-property - -\ #dup f "linearize" set-word-property - : self ( word -- ) f swap dup "infer-effect" word-property (consume/produce) ; diff --git a/library/compiler/x86/stack.factor b/library/compiler/x86/stack.factor new file mode 100644 index 0000000000..535f701c85 --- /dev/null +++ b/library/compiler/x86/stack.factor @@ -0,0 +1,167 @@ +! :folding=none:collapseFolds=1: + +! $Id$ +! +! Copyright (C) 2005 Slava Pestov. +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, +! this list of conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, +! this list of conditions and the following disclaimer in the documentation +! and/or other materials provided with the distribution. +! +! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, +! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; +! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +IN: compiler +USE: inference +USE: kernel +USE: assembler +USE: words +USE: lists +USE: alien + +: rel-ds ( -- ) + #! Add an entry to the relocation table for the 32-bit + #! immediate just compiled. + "ds" f f rel-dlsym ; + +: DS ( -- [ address ] ) "ds" f dlsym unit ; +: DS> ( register -- ) DS MOV rel-ds ; +: >DS ( register -- ) DS swap MOV rel-ds ; + +: rel-cs ( -- ) + #! Add an entry to the relocation table for the 32-bit + #! immediate just compiled. + "cs" f f rel-dlsym ; + +: CS ( -- [ address ] ) "cs" f dlsym unit ; +: CS> ( register -- ) CS MOV rel-cs ; +: >CS ( register -- ) CS swap MOV rel-cs ; + +: PEEK-DS ( -- ) + #! Peek datastack to EAX. + ECX DS> + EAX [ ECX ] MOV ; + +: POP-DS ( -- ) + #! Pop datastack to EAX. + PEEK-DS + ECX 4 SUB + ECX >DS ; + +: PUSH-DS ( -- ) + #! Push EAX to datastack. + ECX 4 ADD + [ ECX ] EAX MOV + ECX >DS ; + +: PEEK-CS ( -- ) + #! Peek return stack to EAX. + ECX CS> + EAX [ ECX ] MOV ; + +: POP-CS ( -- ) + #! Pop return stack to EAX. + PEEK-CS + ECX 4 SUB + ECX >CS ; + +: PUSH-CS ( -- ) + #! Push EAX to return stack. + ECX 4 ADD + [ ECX ] EAX MOV + ECX >CS ; + +: immediate-literal ( obj -- ) + [ ECX ] swap address MOV ; + +: indirect-literal ( obj -- ) + ( EAX [ obj ] MOV ) + EAX swap intern-literal unit MOV rel-address ; + +#push-immediate [ + ECX DS> + ECX 4 ADD + immediate-literal + ECX >DS +] "generator" set-word-property + +#push-indirect [ + ECX DS> + indirect-literal + PUSH-DS +] "generator" set-word-property + +#replace-immediate [ + ECX DS> + immediate-literal +] "generator" set-word-property + +#replace-indirect [ + ECX DS> + indirect-literal + [ ECX ] EAX MOV +] "generator" set-word-property + +\ drop [ + drop + ECX DS> + ECX 4 SUB + ECX >DS +] "generator" set-word-property + +\ dup [ + drop + PEEK-DS + PUSH-DS +] "generator" set-word-property + +\ swap [ + drop + ECX DS> + EAX [ ECX ] MOV + EDX [ ECX -4 ] MOV + [ ECX ] EDX MOV + [ ECX -4 ] EAX MOV +] "generator" set-word-property + +\ over [ + drop + ECX DS> + EAX [ ECX -4 ] MOV + PUSH-DS +] "generator" set-word-property + +\ pick [ + drop + ECX DS> + EAX [ ECX -8 ] MOV + PUSH-DS +] "generator" set-word-property + +\ >r [ + drop + POP-DS + ECX CS> + PUSH-CS +] "generator" set-word-property + +\ r> [ + drop + POP-CS + ECX DS> + PUSH-DS +] "generator" set-word-property diff --git a/library/compiler/xt.factor b/library/compiler/xt.factor index f6fca61b5a..2b966e484f 100644 --- a/library/compiler/xt.factor +++ b/library/compiler/xt.factor @@ -26,6 +26,7 @@ ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. IN: compiler +USE: assembler USE: inference USE: errors USE: hashtables diff --git a/library/inference/dataflow.factor b/library/inference/dataflow.factor index ce083c0485..bca527d19f 100644 --- a/library/inference/dataflow.factor +++ b/library/inference/dataflow.factor @@ -59,18 +59,6 @@ SYMBOL: #values SYMBOL: #return -SYMBOL: #drop -SYMBOL: #dup -SYMBOL: #swap -SYMBOL: #over -SYMBOL: #pick - -SYMBOL: #>r -SYMBOL: #r> - -SYMBOL: #slot -SYMBOL: #set-slot - SYMBOL: node-consume-d SYMBOL: node-produce-d SYMBOL: node-consume-r @@ -118,7 +106,7 @@ SYMBOL: node-param : dataflow-drop, ( -- ) #! Remove the top stack element and add a dataflow node #! noting this. - f #drop dataflow, [ 1 0 node-inputs ] bind ; + f \ drop dataflow, [ 1 0 node-inputs ] bind ; : apply-dataflow ( dataflow name default -- ) #! For the dataflow node, look up named word property, diff --git a/library/inference/stack.factor b/library/inference/stack.factor index 75d5e9386c..3179ddaf27 100644 --- a/library/inference/stack.factor +++ b/library/inference/stack.factor @@ -33,29 +33,25 @@ USE: namespaces USE: words \ >r [ - f #>r dataflow, [ 1 0 node-inputs ] extend + f \ >r dataflow, [ 1 0 node-inputs ] extend pop-d push-r [ 0 1 node-outputs ] bind ] "infer" set-word-property \ r> [ - f #r> dataflow, [ 0 1 node-inputs ] extend + f \ r> dataflow, [ 0 1 node-inputs ] extend pop-r push-d [ 1 0 node-outputs ] bind ] "infer" set-word-property -: meta-infer ( word op -- ) - #! Mark a word as being partially evaluated. - dupd [ - over unit , \ car , - f , , - "infer-effect" word-property , - [ drop host-word ] , - \ with-dataflow , - ] make-list "infer" set-word-property ; +: partial-eval ( word -- ) + #! Partially evaluate a word. + f over dup + "infer-effect" word-property + [ drop host-word ] with-dataflow ; -\ drop #drop meta-infer -\ dup #dup meta-infer -\ swap #swap meta-infer -\ over #over meta-infer -\ pick #pick meta-infer +\ drop [ \ drop partial-eval ] "infer" set-word-property +\ dup [ \ dup partial-eval ] "infer" set-word-property +\ swap [ \ swap partial-eval ] "infer" set-word-property +\ over [ \ over partial-eval ] "infer" set-word-property +\ pick [ \ pick partial-eval ] "infer" set-word-property diff --git a/library/inference/types.factor b/library/inference/types.factor index ea8557f604..e962b5ed90 100644 --- a/library/inference/types.factor +++ b/library/inference/types.factor @@ -67,12 +67,7 @@ USE: prettyprint [ object fixnum ] ensure-d dataflow-drop, pop-d literal-value peek-d value-class builtin-supertypes dup length 1 = [ - cons #slot dataflow, [ - 1 0 node-inputs - [ object ] consume-d - [ object ] produce-d - 1 0 node-outputs - ] bind + cons \ slot [ [ object ] [ object ] ] (consume/produce) ] [ "slot called without static type knowledge" throw ] ifte diff --git a/library/primitives.factor b/library/primitives.factor index ad52311f9b..be4dc0914e 100644 --- a/library/primitives.factor +++ b/library/primitives.factor @@ -30,6 +30,7 @@ DEFER: alien DEFER: dll USE: alien +USE: assembler USE: compiler USE: errors USE: files @@ -50,180 +51,182 @@ USE: words [ [ execute " word -- " f ] - [ call " quot -- " [ [ general-list ] [ ] ] ] - [ ifte " cond true false -- " [ [ object general-list general-list ] [ ] ] ] - [ cons " car cdr -- [ car | cdr ] " [ [ object object ] [ cons ] ] ] - [ " capacity -- vector" [ [ integer ] [ vector ] ] ] - [ vector-nth " n vector -- obj " [ [ integer vector ] [ object ] ] ] - [ set-vector-nth " obj n vector -- " [ [ object integer vector ] [ ] ] ] - [ str-nth " n str -- ch " [ [ integer string ] [ integer ] ] ] - [ str-compare " str str -- -1/0/1 " [ [ string string ] [ integer ] ] ] - [ str= " str str -- ? " [ [ string string ] [ boolean ] ] ] - [ index-of* " n str/ch str -- n " [ [ integer string text ] [ integer ] ] ] - [ substring " start end str -- str " [ [ integer integer string ] [ string ] ] ] - [ str-reverse " str -- str " [ [ string ] [ string ] ] ] - [ " capacity -- sbuf " [ [ integer ] [ sbuf ] ] ] - [ sbuf-length " sbuf -- n " [ [ sbuf ] [ integer ] ] ] - [ set-sbuf-length " n sbuf -- " [ [ integer sbuf ] [ ] ] ] - [ sbuf-nth " n sbuf -- ch " [ [ integer sbuf ] [ integer ] ] ] - [ set-sbuf-nth " ch n sbuf -- " [ [ integer integer sbuf ] [ ] ] ] - [ sbuf-append " ch/str sbuf -- " [ [ text sbuf ] [ ] ] ] - [ sbuf>str " sbuf -- str " [ [ sbuf ] [ string ] ] ] - [ sbuf-reverse " sbuf -- " [ [ sbuf ] [ ] ] ] - [ sbuf-clone " sbuf -- sbuf " [ [ sbuf ] [ sbuf ] ] ] - [ sbuf= " sbuf sbuf -- ? " [ [ sbuf sbuf ] [ boolean ] ] ] - [ sbuf-hashcode " sbuf -- n " [ [ sbuf ] [ fixnum ] ] ] - [ arithmetic-type " n n -- type " [ [ number number ] [ number number fixnum ] ] ] - [ >fixnum " n -- fixnum " [ [ number ] [ fixnum ] ] ] - [ >bignum " n -- bignum " [ [ number ] [ bignum ] ] ] - [ >float " n -- float " [ [ number ] [ float ] ] ] - [ (fraction>) " a b -- a/b " [ [ integer integer ] [ rational ] ] ] - [ str>float " str -- float " [ [ string ] [ float ] ] ] - [ (unparse-float) " float -- str " [ [ float ] [ string ] ] ] - [ (rect>) " re im -- #{ re im } " [ [ real real ] [ number ] ] ] - [ fixnum= " x y -- ? " [ [ fixnum fixnum ] [ boolean ] ] ] - [ fixnum+ " x y -- x+y " [ [ fixnum fixnum ] [ integer ] ] ] - [ fixnum- " x y -- x-y " [ [ fixnum fixnum ] [ integer ] ] ] - [ fixnum* " x y -- x*y " [ [ fixnum fixnum ] [ integer ] ] ] - [ fixnum/i " x y -- x/y " [ [ fixnum fixnum ] [ integer ] ] ] - [ fixnum/f " x y -- x/y " [ [ fixnum fixnum ] [ integer ] ] ] - [ fixnum-mod " x y -- x%y " [ [ fixnum fixnum ] [ fixnum ] ] ] - [ fixnum/mod " x y -- x/y x%y " [ [ fixnum fixnum ] [ integer fixnum ] ] ] - [ fixnum-bitand " x y -- x&y " [ [ fixnum fixnum ] [ fixnum ] ] ] - [ fixnum-bitor " x y -- x|y " [ [ fixnum fixnum ] [ fixnum ] ] ] - [ fixnum-bitxor " x y -- x^y " [ [ fixnum fixnum ] [ fixnum ] ] ] - [ fixnum-bitnot " x -- ~x " [ [ fixnum ] [ fixnum ] ] ] - [ fixnum-shift " x n -- x< " x y -- ? " [ [ fixnum fixnum ] [ boolean ] ] ] - [ fixnum>= " x y -- ? " [ [ fixnum fixnum ] [ boolean ] ] ] - [ bignum= " x y -- ? " [ [ bignum bignum ] [ boolean ] ] ] - [ bignum+ " x y -- x+y " [ [ bignum bignum ] [ bignum ] ] ] - [ bignum- " x y -- x-y " [ [ bignum bignum ] [ bignum ] ] ] - [ bignum* " x y -- x*y " [ [ bignum bignum ] [ bignum ] ] ] - [ bignum/i " x y -- x/y " [ [ bignum bignum ] [ bignum ] ] ] - [ bignum/f " x y -- x/y " [ [ bignum bignum ] [ bignum ] ] ] - [ bignum-mod " x y -- x%y " [ [ bignum bignum ] [ bignum ] ] ] - [ bignum/mod " x y -- x/y x%y " [ [ bignum bignum ] [ bignum bignum ] ] ] - [ bignum-bitand " x y -- x&y " [ [ bignum bignum ] [ bignum ] ] ] - [ bignum-bitor " x y -- x|y " [ [ bignum bignum ] [ bignum ] ] ] - [ bignum-bitxor " x y -- x^y " [ [ bignum bignum ] [ bignum ] ] ] - [ bignum-bitnot " x -- ~x " [ [ bignum ] [ bignum ] ] ] - [ bignum-shift " x n -- x< " x y -- ? " [ [ bignum bignum ] [ boolean ] ] ] - [ bignum>= " x y -- ? " [ [ bignum bignum ] [ boolean ] ] ] - [ float= " x y -- ? " [ [ bignum bignum ] [ boolean ] ] ] - [ float+ " x y -- x+y " [ [ float float ] [ float ] ] ] - [ float- " x y -- x-y " [ [ float float ] [ float ] ] ] - [ float* " x y -- x*y " [ [ float float ] [ float ] ] ] - [ float/f " x y -- x/y " [ [ float float ] [ float ] ] ] - [ float< " x y -- ? " [ [ float float ] [ boolean ] ] ] - [ float<= " x y -- ? " [ [ float float ] [ boolean ] ] ] - [ float> " x y -- ? " [ [ float float ] [ boolean ] ] ] - [ float>= " x y -- ? " [ [ float float ] [ boolean ] ] ] - [ facos " x -- y " [ [ real ] [ float ] ] ] - [ fasin " x -- y " [ [ real ] [ float ] ] ] - [ fatan " x -- y " [ [ real ] [ float ] ] ] - [ fatan2 " x y -- z " [ [ real real ] [ float ] ] ] - [ fcos " x -- y " [ [ real ] [ float ] ] ] - [ fexp " x -- y " [ [ real ] [ float ] ] ] - [ fcosh " x -- y " [ [ real ] [ float ] ] ] - [ flog " x -- y " [ [ real ] [ float ] ] ] - [ fpow " x y -- z " [ [ real real ] [ float ] ] ] - [ fsin " x -- y " [ [ real ] [ float ] ] ] - [ fsinh " x -- y " [ [ real ] [ float ] ] ] - [ fsqrt " x -- y " [ [ real ] [ float ] ] ] - [ " -- word " [ [ ] [ word ] ] ] - [ update-xt " word -- " [ [ word ] [ ] ] ] - [ drop " x -- " [ [ object ] [ ] ] ] - [ dup " x -- x x " [ [ object ] [ object object ] ] ] - [ swap " x y -- y x " [ [ object object ] [ object object ] ] ] - [ over " x y -- x y x " [ [ object object ] [ object object object ] ] ] - [ pick " x y z -- x y z x " [ [ object object object ] [ object object object object ] ] ] - [ >r " x -- r:x " [ [ object ] [ ] ] ] - [ r> " r:x -- x " [ [ ] [ object ] ] ] - [ eq? " x y -- ? " [ [ object object ] [ boolean ] ] ] - [ getenv " n -- obj " [ [ fixnum ] [ object ] ] ] - [ setenv " obj n -- " [ [ object fixnum ] [ ] ] ] - [ open-file " path r w -- port " [ [ string object object ] [ port ] ] ] - [ stat " path -- [ dir? perm size mtime ] " [ [ string ] [ cons ] ] ] - [ (directory) " path -- list " [ [ string ] [ general-list ] ] ] - [ garbage-collection " -- " [ [ ] [ ] ] ] - [ save-image " path -- " [ [ string ] [ ] ] ] - [ datastack " -- ds " f ] - [ callstack " -- cs " f ] - [ set-datastack " ds -- " f ] - [ set-callstack " cs -- " f ] - [ exit* " n -- " [ [ integer ] [ ] ] ] - [ client-socket " host port -- in out " [ [ string integer ] [ port port ] ] ] - [ server-socket " port -- server " [ [ integer ] [ port ] ] ] - [ close-port " port -- " [ [ port ] ] ] - [ add-accept-io-task " server callback -- " [ [ port general-list ] [ ] ] ] - [ accept-fd " server -- host port in out " [ [ port ] [ string integer port port ] ] ] - [ can-read-line? " port -- ? " [ [ port ] [ boolean ] ] ] - [ add-read-line-io-task " port callback -- " [ [ port general-list ] [ ] ] ] - [ read-line-fd-8 " port -- sbuf " [ [ port ] [ sbuf ] ] ] - [ can-read-count? " n port -- ? " [ [ integer port ] [ boolean ] ] ] - [ add-read-count-io-task " n port callback -- " [ [ integer port general-list ] [ ] ] ] - [ read-count-fd-8 " n port -- sbuf " [ [ integer port ] [ sbuf ] ] ] - [ can-write? " n port -- ? " [ [ integer port ] [ boolean ] ] ] - [ add-write-io-task " port callback -- " [ [ port general-list ] [ ] ] ] - [ write-fd-8 " ch/str port -- " [ [ text port ] [ ] ] ] - [ add-copy-io-task " from to callback -- " [ [ port port general-list ] [ ] ] ] - [ pending-io-error " -- " [ [ ] [ ] ] ] - [ next-io-task " -- callback " [ [ ] [ general-list ] ] ] - [ room " -- free total free total " [ [ ] [ integer integer integer integer ] ] ] - [ os-env " str -- str " [ [ string ] [ object ] ] ] - [ millis " -- n " [ [ ] [ integer ] ] ] - [ init-random " -- " [ [ ] [ ] ] ] - [ (random-int) " -- n " [ [ ] [ integer ] ] ] - [ type " obj -- n " [ [ object ] [ fixnum ] ] ] - [ call-profiling " depth -- " [ [ integer ] [ ] ] ] - [ allot-profiling " depth -- " [ [ integer ] [ ] ] ] - [ cwd " -- dir " [ [ ] [ string ] ] ] - [ cd " dir -- " [ [ string ] [ ] ] ] - [ compiled-offset " -- ptr " [ [ ] [ integer ] ] ] - [ set-compiled-offset " ptr -- " [ [ integer ] [ ] ] ] - [ literal-top " -- ptr " [ [ ] [ integer ] ] ] - [ set-literal-top " ptr -- " [ [ integer ] [ ] ] ] - [ address " obj -- ptr " [ [ object ] [ integer ] ] ] - [ dlopen " path -- dll " [ [ string ] [ dll ] ] ] - [ dlsym " name dll -- ptr " [ [ string object ] [ integer ] ] ] - [ dlclose " dll -- " [ [ dll ] [ ] ] ] - [ " ptr -- alien " [ [ integer ] [ alien ] ] ] - [ " len -- alien " [ [ integer ] [ alien ] ] ] - [ alien-cell " alien off -- n " [ [ alien integer ] [ integer ] ] ] - [ set-alien-cell " n alien off -- " [ [ integer alien integer ] [ ] ] ] - [ alien-4 " alien off -- n " [ [ alien integer ] [ integer ] ] ] - [ set-alien-4 " n alien off -- " [ [ integer alien integer ] [ ] ] ] - [ alien-2 " alien off -- n " [ [ alien integer ] [ fixnum ] ] ] - [ set-alien-2 " n alien off -- " [ [ integer alien integer ] [ ] ] ] - [ alien-1 " alien off -- n " [ [ alien integer ] [ fixnum ] ] ] - [ set-alien-1 " n alien off -- " [ [ integer alien integer ] [ ] ] ] - [ heap-stats " -- instances bytes " [ [ ] [ general-list ] ] ] - [ throw " error -- " [ [ object ] [ ] ] ] - [ string>memory " str address -- " [ [ string integer ] [ ] ] ] - [ memory>string " address length -- str " [ [ integer integer ] [ string ] ] ] - [ local-alien? " alien -- ? " [ [ alien ] [ object ] ] ] - [ alien-address " alien -- address " [ [ alien ] [ integer ] ] ] + [ call [ [ general-list ] [ ] ] ] + [ ifte [ [ object general-list general-list ] [ ] ] ] + [ cons [ [ object object ] [ cons ] ] ] + [ [ [ integer ] [ vector ] ] ] + [ vector-nth [ [ integer vector ] [ object ] ] ] + [ set-vector-nth [ [ object integer vector ] [ ] ] ] + [ str-nth [ [ integer string ] [ integer ] ] ] + [ str-compare [ [ string string ] [ integer ] ] ] + [ str= [ [ string string ] [ boolean ] ] ] + [ index-of* [ [ integer string text ] [ integer ] ] ] + [ substring [ [ integer integer string ] [ string ] ] ] + [ str-reverse [ [ string ] [ string ] ] ] + [ [ [ integer ] [ sbuf ] ] ] + [ sbuf-length [ [ sbuf ] [ integer ] ] ] + [ set-sbuf-length [ [ integer sbuf ] [ ] ] ] + [ sbuf-nth [ [ integer sbuf ] [ integer ] ] ] + [ set-sbuf-nth [ [ integer integer sbuf ] [ ] ] ] + [ sbuf-append [ [ text sbuf ] [ ] ] ] + [ sbuf>str [ [ sbuf ] [ string ] ] ] + [ sbuf-reverse [ [ sbuf ] [ ] ] ] + [ sbuf-clone [ [ sbuf ] [ sbuf ] ] ] + [ sbuf= [ [ sbuf sbuf ] [ boolean ] ] ] + [ sbuf-hashcode [ [ sbuf ] [ fixnum ] ] ] + [ arithmetic-type [ [ number number ] [ number number fixnum ] ] ] + [ >fixnum [ [ number ] [ fixnum ] ] ] + [ >bignum [ [ number ] [ bignum ] ] ] + [ >float [ [ number ] [ float ] ] ] + [ (fraction>) [ [ integer integer ] [ rational ] ] ] + [ str>float [ [ string ] [ float ] ] ] + [ (unparse-float) [ [ float ] [ string ] ] ] + [ (rect>) [ [ real real ] [ number ] ] ] + [ fixnum= [ [ fixnum fixnum ] [ boolean ] ] ] + [ fixnum+ [ [ fixnum fixnum ] [ integer ] ] ] + [ fixnum- [ [ fixnum fixnum ] [ integer ] ] ] + [ fixnum* [ [ fixnum fixnum ] [ integer ] ] ] + [ fixnum/i [ [ fixnum fixnum ] [ integer ] ] ] + [ fixnum/f [ [ fixnum fixnum ] [ integer ] ] ] + [ fixnum-mod [ [ fixnum fixnum ] [ fixnum ] ] ] + [ fixnum/mod [ [ fixnum fixnum ] [ integer fixnum ] ] ] + [ fixnum-bitand [ [ fixnum fixnum ] [ fixnum ] ] ] + [ fixnum-bitor [ [ fixnum fixnum ] [ fixnum ] ] ] + [ fixnum-bitxor [ [ fixnum fixnum ] [ fixnum ] ] ] + [ fixnum-bitnot [ [ fixnum ] [ fixnum ] ] ] + [ fixnum-shift [ [ fixnum fixnum ] [ fixnum ] ] ] + [ fixnum< [ [ fixnum fixnum ] [ boolean ] ] ] + [ fixnum<= [ [ fixnum fixnum ] [ boolean ] ] ] + [ fixnum> [ [ fixnum fixnum ] [ boolean ] ] ] + [ fixnum>= [ [ fixnum fixnum ] [ boolean ] ] ] + [ bignum= [ [ bignum bignum ] [ boolean ] ] ] + [ bignum+ [ [ bignum bignum ] [ bignum ] ] ] + [ bignum- [ [ bignum bignum ] [ bignum ] ] ] + [ bignum* [ [ bignum bignum ] [ bignum ] ] ] + [ bignum/i [ [ bignum bignum ] [ bignum ] ] ] + [ bignum/f [ [ bignum bignum ] [ bignum ] ] ] + [ bignum-mod [ [ bignum bignum ] [ bignum ] ] ] + [ bignum/mod [ [ bignum bignum ] [ bignum bignum ] ] ] + [ bignum-bitand [ [ bignum bignum ] [ bignum ] ] ] + [ bignum-bitor [ [ bignum bignum ] [ bignum ] ] ] + [ bignum-bitxor [ [ bignum bignum ] [ bignum ] ] ] + [ bignum-bitnot [ [ bignum ] [ bignum ] ] ] + [ bignum-shift [ [ bignum bignum ] [ bignum ] ] ] + [ bignum< [ [ bignum bignum ] [ boolean ] ] ] + [ bignum<= [ [ bignum bignum ] [ boolean ] ] ] + [ bignum> [ [ bignum bignum ] [ boolean ] ] ] + [ bignum>= [ [ bignum bignum ] [ boolean ] ] ] + [ float= [ [ bignum bignum ] [ boolean ] ] ] + [ float+ [ [ float float ] [ float ] ] ] + [ float- [ [ float float ] [ float ] ] ] + [ float* [ [ float float ] [ float ] ] ] + [ float/f [ [ float float ] [ float ] ] ] + [ float< [ [ float float ] [ boolean ] ] ] + [ float<= [ [ float float ] [ boolean ] ] ] + [ float> [ [ float float ] [ boolean ] ] ] + [ float>= [ [ float float ] [ boolean ] ] ] + [ facos [ [ real ] [ float ] ] ] + [ fasin [ [ real ] [ float ] ] ] + [ fatan [ [ real ] [ float ] ] ] + [ fatan2 [ [ real real ] [ float ] ] ] + [ fcos [ [ real ] [ float ] ] ] + [ fexp [ [ real ] [ float ] ] ] + [ fcosh [ [ real ] [ float ] ] ] + [ flog [ [ real ] [ float ] ] ] + [ fpow [ [ real real ] [ float ] ] ] + [ fsin [ [ real ] [ float ] ] ] + [ fsinh [ [ real ] [ float ] ] ] + [ fsqrt [ [ real ] [ float ] ] ] + [ [ [ ] [ word ] ] ] + [ update-xt [ [ word ] [ ] ] ] + [ drop [ [ object ] [ ] ] ] + [ dup [ [ object ] [ object object ] ] ] + [ swap [ [ object object ] [ object object ] ] ] + [ over [ [ object object ] [ object object object ] ] ] + [ pick [ [ object object object ] [ object object object object ] ] ] + [ >r [ [ object ] [ ] ] ] + [ r> [ [ ] [ object ] ] ] + [ eq? [ [ object object ] [ boolean ] ] ] + [ getenv [ [ fixnum ] [ object ] ] ] + [ setenv [ [ object fixnum ] [ ] ] ] + [ open-file [ [ string object object ] [ port ] ] ] + [ stat [ [ string ] [ cons ] ] ] + [ (directory) [ [ string ] [ general-list ] ] ] + [ garbage-collection [ [ ] [ ] ] ] + [ save-image [ [ string ] [ ] ] ] + [ datastack " -- ds " ] + [ callstack " -- cs " ] + [ set-datastack " ds -- " ] + [ set-callstack " cs -- " ] + [ exit* [ [ integer ] [ ] ] ] + [ client-socket [ [ string integer ] [ port port ] ] ] + [ server-socket [ [ integer ] [ port ] ] ] + [ close-port [ [ port ] ] ] + [ add-accept-io-task [ [ port general-list ] [ ] ] ] + [ accept-fd [ [ port ] [ string integer port port ] ] ] + [ can-read-line? [ [ port ] [ boolean ] ] ] + [ add-read-line-io-task [ [ port general-list ] [ ] ] ] + [ read-line-fd-8 [ [ port ] [ sbuf ] ] ] + [ can-read-count? [ [ integer port ] [ boolean ] ] ] + [ add-read-count-io-task [ [ integer port general-list ] [ ] ] ] + [ read-count-fd-8 [ [ integer port ] [ sbuf ] ] ] + [ can-write? [ [ integer port ] [ boolean ] ] ] + [ add-write-io-task [ [ port general-list ] [ ] ] ] + [ write-fd-8 [ [ text port ] [ ] ] ] + [ add-copy-io-task [ [ port port general-list ] [ ] ] ] + [ pending-io-error [ [ ] [ ] ] ] + [ next-io-task [ [ ] [ general-list ] ] ] + [ room [ [ ] [ integer integer integer integer ] ] ] + [ os-env [ [ string ] [ object ] ] ] + [ millis [ [ ] [ integer ] ] ] + [ init-random [ [ ] [ ] ] ] + [ (random-int) [ [ ] [ integer ] ] ] + [ type [ [ object ] [ fixnum ] ] ] + [ call-profiling [ [ integer ] [ ] ] ] + [ allot-profiling [ [ integer ] [ ] ] ] + [ cwd [ [ ] [ string ] ] ] + [ cd [ [ string ] [ ] ] ] + [ compiled-offset [ [ ] [ integer ] ] ] + [ set-compiled-offset [ [ integer ] [ ] ] ] + [ literal-top [ [ ] [ integer ] ] ] + [ set-literal-top [ [ integer ] [ ] ] ] + [ address [ [ object ] [ integer ] ] ] + [ dlopen [ [ string ] [ dll ] ] ] + [ dlsym [ [ string object ] [ integer ] ] ] + [ dlclose [ [ dll ] [ ] ] ] + [ [ [ integer ] [ alien ] ] ] + [ [ [ integer ] [ alien ] ] ] + [ alien-cell [ [ alien integer ] [ integer ] ] ] + [ set-alien-cell [ [ integer alien integer ] [ ] ] ] + [ alien-4 [ [ alien integer ] [ integer ] ] ] + [ set-alien-4 [ [ integer alien integer ] [ ] ] ] + [ alien-2 [ [ alien integer ] [ fixnum ] ] ] + [ set-alien-2 [ [ integer alien integer ] [ ] ] ] + [ alien-1 [ [ alien integer ] [ fixnum ] ] ] + [ set-alien-1 [ [ integer alien integer ] [ ] ] ] + [ heap-stats [ [ ] [ general-list ] ] ] + [ throw [ [ object ] [ ] ] ] + [ string>memory [ [ string integer ] [ ] ] ] + [ memory>string [ [ integer integer ] [ string ] ] ] + [ local-alien? [ [ alien ] [ object ] ] ] + [ alien-address [ [ alien ] [ integer ] ] ] ! Note: a correct type spec for these would have [ X ] as ! input, not [ object ]. However, we rely on the inferencer ! to handle these specially, since they are also optimized ! out in some cases, etc. - [ >cons " cons -- cons " [ [ object ] [ cons ] ] ] - [ >vector " vector -- vector " [ [ object ] [ vector ] ] ] - [ >string " string -- string " [ [ object ] [ string ] ] ] - [ >word " word -- word " [ [ word ] [ word ] ] ] - [ slot " obj n -- obj " [ [ object fixnum ] [ object ] ] ] - [ set-slot " obj obj n -- " [ [ object object fixnum ] [ ] ] ] - [ integer-slot " obj n -- n " [ [ object fixnum ] [ integer ] ] ] - [ set-integer-slot " n obj n -- " [ [ integer object fixnum ] [ ] ] ] - [ grow-array " n array -- array " [ [ integer array ] [ integer ] ] ] + [ >cons [ [ object ] [ cons ] ] ] + [ >vector [ [ object ] [ vector ] ] ] + [ >string [ [ object ] [ string ] ] ] + [ >word [ [ word ] [ word ] ] ] + [ slot [ [ object fixnum ] [ object ] ] ] + [ set-slot [ [ object object fixnum ] [ ] ] ] + [ integer-slot [ [ object fixnum ] [ integer ] ] ] + [ set-integer-slot [ [ integer object fixnum ] [ ] ] ] + [ grow-array [ [ integer array ] [ integer ] ] ] ] [ - uncons dupd uncons car ( word word stack-effect infer-effect ) - >r "stack-effect" set-word-property r> - "infer-effect" set-word-property + 2unlist dup string? [ + "stack-effect" set-word-property + ] [ + "infer-effect" set-word-property + ] ifte ] each From 72ac889e1b9b970055562a548d2b151efd149523 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 Jan 2005 04:16:13 +0000 Subject: [PATCH 007/122] hand-coded fixnum primitives --- library/compiler/x86/fixnum.factor | 89 ++++++++++++++++++++++++++++-- library/test/benchmark/fac.factor | 11 +++- 2 files changed, 93 insertions(+), 7 deletions(-) diff --git a/library/compiler/x86/fixnum.factor b/library/compiler/x86/fixnum.factor index f7eafdc1e5..cdc1f6dd61 100644 --- a/library/compiler/x86/fixnum.factor +++ b/library/compiler/x86/fixnum.factor @@ -36,15 +36,15 @@ USE: lists USE: math-internals ! This file provides compiling definitions for fixnum words -! that are faster than what C gives us. +! that are faster than what C gives us. There is a lot of +! code repetition here. It will be factored out at the same +! time as rewriting the code to use registers for intermediate +! values happends. At this point in time, this is just a +! prototype to test the assembler. : self ( word -- ) f swap dup "infer-effect" word-property (consume/produce) ; -\ fixnum- [ \ fixnum- self ] "infer" set-word-property - -\ fixnum+ [ \ fixnum+ self ] "infer" set-word-property - : fixnum-insn ( overflow opcode -- ) #! This needs to be factored. ECX DS> @@ -63,6 +63,85 @@ USE: math-internals drop \ fixnum+ \ ADD fixnum-insn ] "generator" set-word-property +\ fixnum+ [ \ fixnum+ self ] "infer" set-word-property + \ fixnum- [ drop \ fixnum- \ SUB fixnum-insn ] "generator" set-word-property + +\ fixnum- [ \ fixnum- self ] "infer" set-word-property + +\ fixnum* [ + drop + ECX DS> + EAX [ ECX -4 ] MOV + EAX 3 SHR + EAX [ ECX ] IMUL + 0 JNO fixup + \ fixnum* compile-call + 0 JMP fixup >r + compiled-offset swap patch + ECX 4 SUB + [ ECX ] EAX MOV + ECX >DS + r> compiled-offset swap patch +] "generator" set-word-property + +\ fixnum* [ \ fixnum* self ] "infer" set-word-property + +\ fixnum/i [ + drop + ECX DS> + EAX [ ECX -4 ] MOV + CDQ + [ ECX ] IDIV + EAX 3 SHL + 0 JNO fixup + \ fixnum/i compile-call + 0 JMP fixup >r + compiled-offset swap patch + ECX 4 SUB + [ ECX ] EAX MOV + ECX >DS + r> compiled-offset swap patch +] "generator" set-word-property + +\ fixnum/i [ \ fixnum/i self ] "infer" set-word-property + +\ fixnum-mod [ + drop + ECX DS> + EAX [ ECX -4 ] MOV + CDQ + [ ECX ] IDIV + EAX 3 SHL + 0 JNO fixup + \ fixnum/i compile-call + 0 JMP fixup >r + compiled-offset swap patch + ECX 4 SUB + [ ECX ] EDX MOV + ECX >DS + r> compiled-offset swap patch +] "generator" set-word-property + +\ fixnum-mod [ \ fixnum-mod self ] "infer" set-word-property + +\ fixnum/mod [ + drop + ECX DS> + EAX [ ECX -4 ] MOV + CDQ + [ ECX ] IDIV + EAX 3 SHL + 0 JNO fixup + \ fixnum/i compile-call + 0 JMP fixup >r + compiled-offset swap patch + [ ECX -4 ] EAX MOV + [ ECX ] EDX MOV + ECX >DS + r> compiled-offset swap patch +] "generator" set-word-property + +\ fixnum/mod [ \ fixnum/mod self ] "infer" set-word-property diff --git a/library/test/benchmark/fac.factor b/library/test/benchmark/fac.factor index 13f6f14379..41dfabc6ee 100644 --- a/library/test/benchmark/fac.factor +++ b/library/test/benchmark/fac.factor @@ -2,8 +2,15 @@ IN: scratchpad USE: math USE: test USE: compiler +USE: kernel -: fac-benchmark +: small-fac-benchmark + #! This tests fixnum math. + 1 swap [ 10 fac 10 [ 1 + / ] times* max ] times ; compiled + +: big-fac-benchmark 10000 fac 10000 [ 1 + / ] times* ; compiled -[ 1 ] [ fac-benchmark ] unit-test +[ 1 ] [ big-fac-benchmark ] unit-test + +[ 1 ] [ 1000000 small-fac-benchmark ] unit-test From d2e68b7f9e8e1259e2ef84577eb9ca6222675f2f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 Jan 2005 19:37:21 +0000 Subject: [PATCH 008/122] update Java Factor parser --- TODO.FACTOR.txt | 4 +- factor/Cons.java | 41 +++++++++--------- factor/DefaultVocabularyLookup.java | 10 +++-- factor/ExternalFactor.java | 4 +- factor/FactorArray.java | 2 +- factor/FactorReader.java | 6 ++- factor/jedit/ListenerAttributeSet.java | 5 +-- factor/parser/BeginConstructor.java | 9 ++-- factor/parser/BeginMethod.java | 11 ++--- factor/parser/BeginPredicate.java | 58 ++++++++++++++++++++++++++ factor/parser/BeginUnion.java | 54 ++++++++++++++++++++++++ factor/parser/Def.java | 9 ++-- factor/parser/Ine.java | 14 ++----- library/hashtables.factor | 2 +- library/math/math.factor | 2 +- 15 files changed, 170 insertions(+), 61 deletions(-) create mode 100644 factor/parser/BeginPredicate.java create mode 100644 factor/parser/BeginUnion.java diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 3586470651..8aa8c2b966 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,9 +1,11 @@ + compiler: - type inference fails with some assembler words +- more accurate type inference in some cases - optimize away dispatch +- goal: to compile hash* optimally +- type check/not-check entry points for compiled words - getenv/setenv: if literal arg, compile as a load/store -- update compiler for new assembler + oop: diff --git a/factor/Cons.java b/factor/Cons.java index 4d678a6be0..76412eafce 100644 --- a/factor/Cons.java +++ b/factor/Cons.java @@ -3,7 +3,7 @@ /* * $Id$ * - * Copyright (C) 2003, 2004 Slava Pestov. + * Copyright (C) 2003, 2005 Slava Pestov. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are met: @@ -30,7 +30,7 @@ package factor; /** - * Used to build up linked lists. + * Used to build up linked lists in Factor style. */ public class Cons implements FactorExternalizable { @@ -51,40 +51,41 @@ public class Cons implements FactorExternalizable } //}}} //{{{ contains() method - public boolean contains(Object obj) + public static boolean contains(Cons list, Object obj) { - Cons iter = this; - while(iter != null) + while(list != null) { - if(FactorLib.objectsEqual(obj,iter.car)) + if(FactorLib.objectsEqual(obj,list.car)) return true; - iter = iter.next(); + list = list.next(); } return false; } //}}} - //{{{ contains() method - public static boolean contains(Cons list, Object obj) - { - if(list == null) - return false; - else - return list.contains(obj); - } //}}} - //{{{ length() method - public int length() + public static int length(Cons list) { int size = 0; - Cons iter = this; - while(iter != null) + while(list != null) { - iter = (Cons)iter.cdr; size++; + list = list.next(); } return size; } //}}} + //{{{ reverse() method + public static Cons reverse(Cons list) + { + Cons reversed = null; + while(list != null) + { + reversed = new Cons(list.car,reversed); + list = list.next(); + } + return reversed; + } //}}} + //{{{ elementsToString() method /** * Returns a whitespace separated string of the unparseObject() of each diff --git a/factor/DefaultVocabularyLookup.java b/factor/DefaultVocabularyLookup.java index 88a7bee609..256336c3b6 100644 --- a/factor/DefaultVocabularyLookup.java +++ b/factor/DefaultVocabularyLookup.java @@ -89,7 +89,7 @@ public class DefaultVocabularyLookup implements VocabularyLookup def.parsing = new Def(def); def.docComment = true; FactorWord ine = define("syntax",";"); - ine.parsing = new Ine(def,ine); + ine.parsing = new Ine(ine); FactorWord symbol = define("syntax","SYMBOL:"); symbol.parsing = new Definer(symbol); @@ -120,9 +120,13 @@ public class DefaultVocabularyLookup implements VocabularyLookup FactorWord traits = define("generic","TRAITS:"); traits.parsing = new Definer(traits); FactorWord beginMethod = define("generic","M:"); - beginMethod.parsing = new BeginMethod(beginMethod,def); + beginMethod.parsing = new BeginMethod(beginMethod); FactorWord beginConstructor = define("generic","C:"); - beginConstructor.parsing = new BeginConstructor(beginConstructor,def); + beginConstructor.parsing = new BeginConstructor(beginConstructor); + FactorWord beginPredicate = define("generic","PREDICATE:"); + beginPredicate.parsing = new BeginPredicate(beginPredicate); + FactorWord beginUnion = define("generic","UNION:"); + beginUnion.parsing = new BeginUnion(beginUnion); } //}}} //{{{ getVocabulary() method diff --git a/factor/ExternalFactor.java b/factor/ExternalFactor.java index 09222d3161..6d6f6a6afc 100644 --- a/factor/ExternalFactor.java +++ b/factor/ExternalFactor.java @@ -104,7 +104,7 @@ public class ExternalFactor extends DefaultVocabularyLookup byte[] discard = new byte[2048]; int len = in.read(discard,0,discard.length); discardStr = new String(discard,0,len); - Log.log(Log.DEBUG,this,"Waiting for ACK: " + discardStr); + // Log.log(Log.DEBUG,this,"Waiting for ACK: " + discardStr); } } //}}} @@ -123,7 +123,7 @@ public class ExternalFactor extends DefaultVocabularyLookup */ public synchronized String eval(String cmd) throws IOException { - if(isClosed) + if(isClosed()) throw new IOException("ExternalFactor stream closed"); try diff --git a/factor/FactorArray.java b/factor/FactorArray.java index 4d4160dd9b..839db77c4b 100644 --- a/factor/FactorArray.java +++ b/factor/FactorArray.java @@ -53,7 +53,7 @@ public class FactorArray implements FactorExternalizable //{{{ FactorArray constructor public FactorArray(Cons list) { - this(list == null ? 0 : list.length()); + this(Cons.length(list)); int i = 0; while(list != null) diff --git a/factor/FactorReader.java b/factor/FactorReader.java index 47a24f954b..db5f6e31a5 100644 --- a/factor/FactorReader.java +++ b/factor/FactorReader.java @@ -258,7 +258,7 @@ public class FactorReader //{{{ getDefinedWords() method public Cons getDefinedWords() { - return definedWords; + return Cons.reverse(definedWords); } //}}} //{{{ nextWord() method @@ -381,12 +381,14 @@ public class FactorReader /** * Pop a parser state, throw exception if it doesn't match the * parameter. + * @param start The start parameter that must match. If this is null, + * any start is acceptable. */ public ParseState popState(FactorWord start, FactorWord end) throws FactorParseException { ParseState state = getCurrentState(); - if(state.start != start) + if(start != null && state.start != start) scanner.error(end + " does not close " + state.start); if(states.next() != null) states = states.next(); diff --git a/factor/jedit/ListenerAttributeSet.java b/factor/jedit/ListenerAttributeSet.java index 6c8f4f07b1..0c230e2686 100644 --- a/factor/jedit/ListenerAttributeSet.java +++ b/factor/jedit/ListenerAttributeSet.java @@ -87,10 +87,7 @@ public class ListenerAttributeSet extends SimpleAttributeSet //{{{ createActionsMenu() method private Action[] createActionsMenu(Cons alist) { - if(alist == null) - return null; - - int length = alist.length(); + int length = Cons.length(alist); int i = 0; Action[] actions = new Action[length]; while(alist != null) diff --git a/factor/parser/BeginConstructor.java b/factor/parser/BeginConstructor.java index 5390d79d60..17f9f1697c 100644 --- a/factor/parser/BeginConstructor.java +++ b/factor/parser/BeginConstructor.java @@ -33,12 +33,9 @@ import factor.*; public class BeginConstructor extends FactorParsingDefinition { - private FactorWord colon; - - public BeginConstructor(FactorWord word, FactorWord colon) + public BeginConstructor(FactorWord word) { super(word); - this.colon = colon; } public void eval(FactorReader reader) @@ -48,6 +45,8 @@ public class BeginConstructor extends FactorParsingDefinition if(type == null) return; - reader.pushExclusiveState(colon,type); + reader.intern("<" + type + ">",true); + + reader.pushExclusiveState(word,type); } } diff --git a/factor/parser/BeginMethod.java b/factor/parser/BeginMethod.java index 969101b8d3..776fb44db0 100644 --- a/factor/parser/BeginMethod.java +++ b/factor/parser/BeginMethod.java @@ -33,12 +33,9 @@ import factor.*; public class BeginMethod extends FactorParsingDefinition { - private FactorWord colon; - - public BeginMethod(FactorWord word, FactorWord colon) + public BeginMethod(FactorWord word) { super(word); - this.colon = colon; } public void eval(FactorReader reader) @@ -48,10 +45,10 @@ public class BeginMethod extends FactorParsingDefinition if(type == null) return; - FactorWord generic = reader.nextWord(false); - if(generic == null) + FactorWord newWord = reader.nextWord(false); + if(newWord == null) return; - reader.pushExclusiveState(colon,generic); + reader.pushExclusiveState(word,newWord); } } diff --git a/factor/parser/BeginPredicate.java b/factor/parser/BeginPredicate.java new file mode 100644 index 0000000000..88aa2ea260 --- /dev/null +++ b/factor/parser/BeginPredicate.java @@ -0,0 +1,58 @@ +/* :folding=explicit:collapseFolds=1: */ + +/* + * $Id$ + * + * Copyright (C) 2004 Slava Pestov. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * 1. Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND + * FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; + * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, + * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR + * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF + * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + */ + +package factor.parser; + +import factor.*; + +public class BeginPredicate extends FactorParsingDefinition +{ + public BeginPredicate(FactorWord word) + { + super(word); + } + + public void eval(FactorReader reader) + throws Exception + { + FactorWord supertype = reader.nextWord(false); + if(supertype == null) + return; + + FactorWord type = reader.nextWord(true); + if(type == null) + return; + + type.setDefiner(word); + + reader.intern(type + "?",true); + + reader.pushExclusiveState(word,type); + } +} diff --git a/factor/parser/BeginUnion.java b/factor/parser/BeginUnion.java new file mode 100644 index 0000000000..2496ed9299 --- /dev/null +++ b/factor/parser/BeginUnion.java @@ -0,0 +1,54 @@ +/* :folding=explicit:collapseFolds=1: */ + +/* + * $Id$ + * + * Copyright (C) 2004 Slava Pestov. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * 1. Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND + * FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; + * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, + * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR + * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF + * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + */ + +package factor.parser; + +import factor.*; + +public class BeginUnion extends FactorParsingDefinition +{ + public BeginUnion(FactorWord word) + { + super(word); + } + + public void eval(FactorReader reader) + throws Exception + { + FactorWord type = reader.nextWord(true); + if(type == null) + return; + + type.setDefiner(word); + + reader.intern(type + "?",true); + + reader.pushExclusiveState(word,type); + } +} diff --git a/factor/parser/Def.java b/factor/parser/Def.java index e71a1be04e..12ac74e448 100644 --- a/factor/parser/Def.java +++ b/factor/parser/Def.java @@ -43,9 +43,10 @@ public class Def extends FactorParsingDefinition { FactorWord newWord = reader.nextWord(true); - if(newWord == null) - return; - - reader.pushExclusiveState(word,newWord); + if(newWord != null) + { + newWord.setDefiner(word); + reader.pushExclusiveState(word,newWord); + } } } diff --git a/factor/parser/Ine.java b/factor/parser/Ine.java index e729053eda..5c6ecc0906 100644 --- a/factor/parser/Ine.java +++ b/factor/parser/Ine.java @@ -33,22 +33,16 @@ import factor.*; public class Ine extends FactorParsingDefinition { - public FactorWord start; - - public Ine(FactorWord start, FactorWord end) + public Ine(FactorWord end) { super(end); - this.start = start; } public void eval(FactorReader reader) throws Exception { - FactorReader.ParseState state = reader.popState(start,word); - FactorWord w = state.defining; - /* Only ever null with restartable scanner; - error already logged, so give up */ - if(w != null) - w.setDefiner(start); + FactorReader.ParseState state = reader.popState(null,word); + if(state.defining == null) + reader.getScanner().error(word + " does not close " + state.start); } } diff --git a/library/hashtables.factor b/library/hashtables.factor index f7fedec75d..277459f16e 100644 --- a/library/hashtables.factor +++ b/library/hashtables.factor @@ -48,7 +48,7 @@ PREDICATE: vector hashtable ( obj -- ? ) : (hashcode) ( key table -- index ) #! Compute the index of the bucket for a key. - >r hashcode r> vector-length rem ; + >r hashcode r> vector-length rem ; inline : hash* ( key table -- [ key | value ] ) #! Look up a value in the hashtable. First the bucket is diff --git a/library/math/math.factor b/library/math/math.factor index d784356444..9b713d4d5d 100644 --- a/library/math/math.factor +++ b/library/math/math.factor @@ -92,7 +92,7 @@ M: number = ( n n -- ? ) number= ; : rem ( x y -- x%y ) #! Like modulus, but always gives a positive result. - [ mod ] keep over 0 < [ + ] [ drop ] ifte ; + [ mod ] keep over 0 < [ + ] [ drop ] ifte ; inline : sgn ( n -- -1/0/1 ) #! Push the sign of a real number. From fd64bc4ccceb99f9b8b0a03f22c490243e5d645a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 Jan 2005 20:22:12 +0000 Subject: [PATCH 009/122] Buffer processor for generating automatic type unit tests --- factor/jedit/FactorBufferProcessor.java | 93 +++++++++++++++++++++++++ factor/jedit/FactorPlugin.java | 54 +++++++------- factor/jedit/FactorSideKickParser.java | 7 +- factor/jedit/WordPreview.java | 6 +- 4 files changed, 126 insertions(+), 34 deletions(-) create mode 100644 factor/jedit/FactorBufferProcessor.java diff --git a/factor/jedit/FactorBufferProcessor.java b/factor/jedit/FactorBufferProcessor.java new file mode 100644 index 0000000000..a7ea200653 --- /dev/null +++ b/factor/jedit/FactorBufferProcessor.java @@ -0,0 +1,93 @@ +/* :folding=explicit:collapseFolds=1: */ + +/* + * $Id$ + * + * Copyright (C) 2005 Slava Pestov. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * 1. Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND + * FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; + * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, + * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR + * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF + * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + */ + +package factor.jedit; + +import factor.*; +import java.io.IOException; +import java.util.*; +import org.gjt.sp.jedit.Buffer; + +/** + * A class used to compile all words in a file, or infer stack effects of all + * words in a file, etc. + */ +public class FactorBufferProcessor +{ + private String code; + private LinkedHashMap results; + + //{{{ FactorBufferProcessor constructor + /** + * @param buffer The buffer + * @param code The snippet of code to apply to each word. The snippet + * should print a string. + */ + public FactorBufferProcessor(Buffer buffer, String code, ExternalFactor factor) + throws IOException + { + results = new LinkedHashMap(); + this.code = code; + + Cons words = (Cons)buffer.getProperty( + FactorSideKickParser.WORDS_PROPERTY); + Cons wordCodeMap = null; + while(words != null) + { + FactorWord word = (FactorWord)words.car; + + StringBuffer expression = new StringBuffer(); + expression.append(FactorPlugin.factorWord(word)); + expression.append(" "); + expression.append(code); + + results.put(word,factor.eval(expression.toString())); + + words = words.next(); + } + } //}}} + + //{{{ insertResults() method + public void insertResults(Buffer buffer, int offset) + { + StringBuffer result = new StringBuffer(); + Iterator iter = results.entrySet().iterator(); + while(iter.hasNext()) + { + Map.Entry entry = (Map.Entry)iter.next(); + result.append("[ "); + result.append(((String)entry.getValue()).trim()); + result.append(" ] [ \\ "); + result.append(FactorReader.unparseObject(entry.getKey())); + result.append(code); + result.append(" ] unit-test\n"); + } + buffer.insert(offset,result.toString()); + } //}}} +} diff --git a/factor/jedit/FactorPlugin.java b/factor/jedit/FactorPlugin.java index b1b1c583ec..b8c7a4e3c0 100644 --- a/factor/jedit/FactorPlugin.java +++ b/factor/jedit/FactorPlugin.java @@ -193,6 +193,16 @@ public class FactorPlugin extends EditPlugin "sidekick.SideKickParser","factor"); } //}}} + //{{{ getParsedData() method + public static FactorParsedData getParsedData(View view) + { + SideKickParsedData data = SideKickParsedData.getParsedData(view); + if(data instanceof FactorParsedData) + return (FactorParsedData)data; + else + return null; + } //}}} + //{{{ evalInListener() method public static void evalInListener(View view, String cmd) { @@ -214,14 +224,11 @@ public class FactorPlugin extends EditPlugin */ public static FactorWord lookupWord(View view, String word) { - SideKickParsedData data = SideKickParsedData.getParsedData(view); - if(data instanceof FactorParsedData) - { - FactorParsedData fdata = (FactorParsedData)data; - return getExternalInstance().searchVocabulary(fdata.use,word); - } - else + FactorParsedData fdata = getParsedData(view); + if(fdata == null) return null; + else + return getExternalInstance().searchVocabulary(fdata.use,word); } //}}} //{{{ factorWord() method @@ -230,18 +237,14 @@ public class FactorPlugin extends EditPlugin */ public static String factorWord(View view, String word) { - SideKickParsedData data = SideKickParsedData - .getParsedData(view); - if(data instanceof FactorParsedData) - { - FactorParsedData fdata = (FactorParsedData)data; - return "\"" - + FactorReader.charsToEscapes(word) - + "\" " + FactorReader.unparseObject(fdata.use) - + " search"; - } - else + FactorParsedData fdata = getParsedData(view); + if(fdata == null) return null; + + return "\"" + + FactorReader.charsToEscapes(word) + + "\" " + FactorReader.unparseObject(fdata.use) + + " search"; } //}}} //{{{ factorWord() method @@ -403,16 +406,14 @@ public class FactorPlugin extends EditPlugin //{{{ isUsed() method public static boolean isUsed(View view, String vocab) { - SideKickParsedData data = SideKickParsedData - .getParsedData(view); - if(data instanceof FactorParsedData) + FactorParsedData fdata = getParsedData(view); + if(fdata == null) + return false; + else { - FactorParsedData fdata = (FactorParsedData)data; Cons use = fdata.use; return Cons.contains(use,vocab); } - else - return false; } //}}} //{{{ findAllWordsNamed() method @@ -514,9 +515,8 @@ public class FactorPlugin extends EditPlugin if(selection == null) selection = ""; - SideKickParsedData data = SideKickParsedData - .getParsedData(view); - if(!(data instanceof FactorParsedData)) + FactorParsedData data = getParsedData(view); + if(data == null) { view.getToolkit().beep(); return; diff --git a/factor/jedit/FactorSideKickParser.java b/factor/jedit/FactorSideKickParser.java index 6c3649d572..8afd403d1a 100644 --- a/factor/jedit/FactorSideKickParser.java +++ b/factor/jedit/FactorSideKickParser.java @@ -245,11 +245,10 @@ public class FactorSideKickParser extends SideKickParser */ public SideKickCompletion complete(EditPane editPane, int caret) { - SideKickParsedData _data = SideKickParsedData - .getParsedData(editPane.getView()); - if(!(_data instanceof FactorParsedData)) + FactorParsedData data = FactorPlugin.getParsedData( + editPane.getView()); + if(data == null) return null; - FactorParsedData data = (FactorParsedData)_data; Buffer buffer = editPane.getBuffer(); diff --git a/factor/jedit/WordPreview.java b/factor/jedit/WordPreview.java index fcf52aeaf2..6e33284617 100644 --- a/factor/jedit/WordPreview.java +++ b/factor/jedit/WordPreview.java @@ -134,10 +134,10 @@ public class WordPreview implements ActionListener, CaretListener if(SideKickPlugin.isParsingBuffer(view.getBuffer())) return; - SideKickParsedData data = SideKickParsedData.getParsedData(view); - if(data instanceof FactorParsedData) + FactorParsedData data = FactorPlugin.getParsedData(view); + if(data != null) { - FactorWord w = getWordAtCaret((FactorParsedData)data); + FactorWord w = getWordAtCaret(data); if(w != null) { view.getStatus().setMessageAndClear( From c56ca0ca1f1f084ac5555d1107d913be9368d131 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 8 Jan 2005 04:54:23 +0000 Subject: [PATCH 010/122] command to infer stack effects of all words in file --- actions.xml | 6 ++ factor/jedit/FactorBufferProcessor.java | 44 +++++-------- factor/jedit/FactorPlugin.props | 3 + factor/jedit/InferBufferProcessor.java | 87 +++++++++++++++++++++++++ library/bootstrap/boot-stage2.factor | 1 + library/inference/inference.factor | 4 -- library/inference/test.factor | 53 +++++++++++++++ library/test/test.factor | 2 - 8 files changed, 165 insertions(+), 35 deletions(-) create mode 100644 factor/jedit/InferBufferProcessor.java create mode 100644 library/inference/test.factor diff --git a/actions.xml b/actions.xml index ee174c35d5..6745783f60 100644 --- a/actions.xml +++ b/actions.xml @@ -82,4 +82,10 @@ FactorPlugin.extractWord(view); + + + InferBufferProcessor.createInferUnitTests(view,buffer, + FactorPlugin.getExternalInstance()); + + diff --git a/factor/jedit/FactorBufferProcessor.java b/factor/jedit/FactorBufferProcessor.java index a7ea200653..9c85a9f82e 100644 --- a/factor/jedit/FactorBufferProcessor.java +++ b/factor/jedit/FactorBufferProcessor.java @@ -38,22 +38,15 @@ import org.gjt.sp.jedit.Buffer; * A class used to compile all words in a file, or infer stack effects of all * words in a file, etc. */ -public class FactorBufferProcessor +public abstract class FactorBufferProcessor { - private String code; private LinkedHashMap results; //{{{ FactorBufferProcessor constructor - /** - * @param buffer The buffer - * @param code The snippet of code to apply to each word. The snippet - * should print a string. - */ - public FactorBufferProcessor(Buffer buffer, String code, ExternalFactor factor) - throws IOException + public FactorBufferProcessor(Buffer buffer, ExternalFactor factor) + throws Exception { results = new LinkedHashMap(); - this.code = code; Cons words = (Cons)buffer.getProperty( FactorSideKickParser.WORDS_PROPERTY); @@ -61,33 +54,26 @@ public class FactorBufferProcessor while(words != null) { FactorWord word = (FactorWord)words.car; - - StringBuffer expression = new StringBuffer(); - expression.append(FactorPlugin.factorWord(word)); - expression.append(" "); - expression.append(code); - - results.put(word,factor.eval(expression.toString())); - + String expr = processWord(word); + System.err.println(expr); + results.put(word,factor.eval(expr)); words = words.next(); } } //}}} + /** + * @return Code to process the word. + */ + public abstract String processWord(FactorWord word); + //{{{ insertResults() method public void insertResults(Buffer buffer, int offset) + throws Exception { StringBuffer result = new StringBuffer(); - Iterator iter = results.entrySet().iterator(); + Iterator iter = results.values().iterator(); while(iter.hasNext()) - { - Map.Entry entry = (Map.Entry)iter.next(); - result.append("[ "); - result.append(((String)entry.getValue()).trim()); - result.append(" ] [ \\ "); - result.append(FactorReader.unparseObject(entry.getKey())); - result.append(code); - result.append(" ] unit-test\n"); - } - buffer.insert(offset,result.toString()); + result.append(iter.next()); + buffer.insert(offset,result.toString().trim()); } //}}} } diff --git a/factor/jedit/FactorPlugin.props b/factor/jedit/FactorPlugin.props index 85dba2b6b0..ed79bed93b 100644 --- a/factor/jedit/FactorPlugin.props +++ b/factor/jedit/FactorPlugin.props @@ -29,6 +29,8 @@ plugin.factor.jedit.FactorPlugin.menu=factor-listener \ - \ factor-extract-word \ - \ + factor-infer-effects \ + - \ factor-restart factor-listener.label=Listener @@ -41,6 +43,7 @@ factor-edit.label=Edit word at caret factor-edit-dialog.label=Edit word... factor-usages.label=Word usages at caret factor-extract-word.label=Extract word... +factor-infer-effects.label=Infer word stack effects... factor-restart.label=Restart Factor # SideKick stuff diff --git a/factor/jedit/InferBufferProcessor.java b/factor/jedit/InferBufferProcessor.java new file mode 100644 index 0000000000..cfc266fcec --- /dev/null +++ b/factor/jedit/InferBufferProcessor.java @@ -0,0 +1,87 @@ +/* :folding=explicit:collapseFolds=1: */ + +/* + * $Id$ + * + * Copyright (C) 2005 Slava Pestov. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * 1. Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND + * FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; + * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, + * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR + * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF + * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + */ + +package factor.jedit; + +import factor.*; +import java.io.IOException; +import java.util.*; +import org.gjt.sp.jedit.io.VFSManager; +import org.gjt.sp.jedit.*; +import org.gjt.sp.util.*; + +/** + * A class used to compile all words in a file, or infer stack effects of all + * words in a file, etc. + */ +public class InferBufferProcessor extends FactorBufferProcessor +{ + //{{{ createInferUnitTests() method + public static void createInferUnitTests(View view, + final Buffer buffer, + final ExternalFactor factor) + { + final Buffer newBuffer = jEdit.newFile(view); + VFSManager.runInAWTThread(new Runnable() + { + public void run() + { + newBuffer.setMode("factor"); + try + { + new InferBufferProcessor(buffer,factor) + .insertResults(newBuffer,0); + } + catch(Exception e) + { + Log.log(Log.ERROR,this,e); + } + } + }); + } //}}} + + //{{{ InferBufferProcessor constructor + public InferBufferProcessor(Buffer buffer, ExternalFactor factor) + throws Exception + { + super(buffer,factor); + } //}}} + + //{{{ processWord() method + /** + * @return Code to process the word. + */ + public String processWord(FactorWord word) + { + StringBuffer expression = new StringBuffer(); + expression.append(FactorPlugin.factorWord(word)); + expression.append(" unit infer>test print"); + return expression.toString(); + } //}}} +} diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index 0eb5df43ff..c9b75a48b3 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -118,6 +118,7 @@ USE: namespaces "/library/inference/words.factor" "/library/inference/stack.factor" "/library/inference/types.factor" + "/library/inference/test.factor" "/library/compiler/assembler.factor" "/library/compiler/xt.factor" diff --git a/library/inference/inference.factor b/library/inference/inference.factor index 4d66760ebe..2ee4c4c9b8 100644 --- a/library/inference/inference.factor +++ b/library/inference/inference.factor @@ -188,10 +188,6 @@ DEFER: apply-word #! Stack effect of a quotation. [ (infer) effect ] with-scope ; -: try-infer ( quot -- effect/f ) - #! Push f if inference fails. - [ infer ] [ [ drop f ] when ] catch ; - : dataflow ( quot -- dataflow ) #! Data flow of a quotation. [ (infer) get-dataflow ] with-scope ; diff --git a/library/inference/test.factor b/library/inference/test.factor new file mode 100644 index 0000000000..9cbd8166d3 --- /dev/null +++ b/library/inference/test.factor @@ -0,0 +1,53 @@ +! :folding=indent:collapseFolds=1: + +! $Id$ +! +! Copyright (C) 2005 Slava Pestov. +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, +! this list of conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, +! this list of conditions and the following disclaimer in the documentation +! and/or other materials provided with the distribution. +! +! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, +! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; +! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +IN: test +USE: errors +USE: inference +USE: kernel +USE: lists +USE: prettyprint +USE: stdio +USE: strings +USE: unparser + +: try-infer ( quot -- effect error ) + [ infer f ] [ [ >r drop f r> ] when* ] catch ; + +: infer-fail ( quot error -- ) + "! " , dup string? [ unparse ] unless , "\n" , + [ [ infer ] cons . \ unit-test-fails . ] with-string , ; + +: infer-pass ( quot effect -- ) + [ unit . [ infer ] cons . \ unit-test . ] with-string , ; + +: infer>test ( quot -- str ) + #! Make a string representing a unit test for the stack + #! effect of a word. + [ + dup try-infer [ infer-fail ] [ infer-pass ] ?ifte + ] make-string ; diff --git a/library/test/test.factor b/library/test/test.factor index 54496d8c70..6aa91411a8 100644 --- a/library/test/test.factor +++ b/library/test/test.factor @@ -1,7 +1,5 @@ ! Factor test suite. -! Some of these words should be moved to the standard library. - IN: test USE: errors USE: kernel From f6e3f24f908566d56cbbe2d3efeb270cd4666533 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 8 Jan 2005 05:15:35 +0000 Subject: [PATCH 011/122] some refactoring --- factor/jedit/FactorPlugin.props | 7 ++- .../{WordPopup.java => TextAreaPopup.java} | 59 +++++++------------ 2 files changed, 28 insertions(+), 38 deletions(-) rename factor/jedit/{WordPopup.java => TextAreaPopup.java} (82%) diff --git a/factor/jedit/FactorPlugin.props b/factor/jedit/FactorPlugin.props index ed79bed93b..0f35839ae2 100644 --- a/factor/jedit/FactorPlugin.props +++ b/factor/jedit/FactorPlugin.props @@ -29,6 +29,9 @@ plugin.factor.jedit.FactorPlugin.menu=factor-listener \ - \ factor-extract-word \ - \ + factor-infer-effect \ + factor-compile \ + - \ factor-infer-effects \ - \ factor-restart @@ -43,7 +46,9 @@ factor-edit.label=Edit word at caret factor-edit-dialog.label=Edit word... factor-usages.label=Word usages at caret factor-extract-word.label=Extract word... -factor-infer-effects.label=Infer word stack effects... +factor-infer-effect.label=Infer word stack effect +factor-compile.label=Compile word at caret +factor-infer-effects.label=Infer word stack effects factor-restart.label=Restart Factor # SideKick stuff diff --git a/factor/jedit/WordPopup.java b/factor/jedit/TextAreaPopup.java similarity index 82% rename from factor/jedit/WordPopup.java rename to factor/jedit/TextAreaPopup.java index 7540359181..94e3e3ad2f 100644 --- a/factor/jedit/WordPopup.java +++ b/factor/jedit/TextAreaPopup.java @@ -38,48 +38,16 @@ import org.gjt.sp.jedit.textarea.JEditTextArea; import org.gjt.sp.jedit.*; import org.gjt.sp.util.Log; -public class WordPopup extends JWindow +public class TextAreaPopup extends JWindow { private View view; private JTextArea preview; - //{{{ showWordPopup() method - public static void showWordPopup(JEditTextArea textArea) + //{{{ TextAreaPopup constructor + public TextAreaPopup(JEditTextArea textArea, String text) { - View view = GUIUtilities.getView(textArea); - String def; - - try - { - def = FactorPlugin.evalInWire( - FactorPlugin.factorWord(view) - + " see").trim(); - } - catch(IOException io) - { - def = io.toString(); - Log.log(Log.ERROR,WordPopup.class,io); - } - - WordPopup popup = new WordPopup(view,def); - - int line = textArea.getCaretLine(); - String lineText = textArea.getLineText(line); - int caret = textArea.getCaretPosition() - - textArea.getLineStartOffset(line); - int start = FactorPlugin.getWordStartOffset(lineText,caret); - Point loc = textArea.offsetToXY(line,start); - loc.y += textArea.getPainter().getFontMetrics().getHeight(); - SwingUtilities.convertPointToScreen(loc,textArea.getPainter()); - popup.setLocation(loc); - popup.show(); - } //}}} - - //{{{ WordPopup constructor - public WordPopup(View view, String text) - { - super(view); - this.view = view; + super(GUIUtilities.getView(textArea)); + this.view = GUIUtilities.getView(textArea); preview = new JTextArea(text); preview.setEditable(false); getContentPane().add(BorderLayout.CENTER,new JScrollPane(preview)); @@ -91,6 +59,23 @@ public class WordPopup extends JWindow view.setKeyEventInterceptor(keyHandler); GUIUtilities.requestFocus(this,preview); + + positionAtCaret(textArea); + setVisible(true); + } //}}} + + //{{{ positionAtCaret() method + private void positionAtCaret(JEditTextArea textArea) + { + int line = textArea.getCaretLine(); + String lineText = textArea.getLineText(line); + int caret = textArea.getCaretPosition() + - textArea.getLineStartOffset(line); + int start = FactorPlugin.getWordStartOffset(lineText,caret); + Point loc = textArea.offsetToXY(line,start); + loc.y += textArea.getPainter().getFontMetrics().getHeight(); + SwingUtilities.convertPointToScreen(loc,textArea.getPainter()); + setLocation(loc); } //}}} //{{{ KeyHandler class From a1a1e88d020c2359cdaea89def53881518ad0fb9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 8 Jan 2005 05:33:03 +0000 Subject: [PATCH 012/122] plugin improved --- actions.xml | 12 +++++++++++- factor/jedit/FactorPlugin.java | 16 ++++++++++++++++ factor/jedit/FactorPlugin.props | 4 ++-- 3 files changed, 29 insertions(+), 3 deletions(-) diff --git a/actions.xml b/actions.xml index 6745783f60..5f787210a1 100644 --- a/actions.xml +++ b/actions.xml @@ -49,7 +49,7 @@ - WordPopup.showWordPopup(textArea); + FactorPlugin.factorWordPopupOp(view,"see"); @@ -82,6 +82,16 @@ FactorPlugin.extractWord(view); + + + FactorPlugin.factorWordPopupOp(view,"unit infer ."); + + + + + FactorPlugin.factorWordOutputOp(view,"recompile"); + + InferBufferProcessor.createInferUnitTests(view,buffer, diff --git a/factor/jedit/FactorPlugin.java b/factor/jedit/FactorPlugin.java index b8c7a4e3c0..97f2a49185 100644 --- a/factor/jedit/FactorPlugin.java +++ b/factor/jedit/FactorPlugin.java @@ -298,6 +298,22 @@ public class FactorPlugin extends EditPlugin evalInWire(word + " " + op); } //}}} + //{{{ factorWordPopupOp() method + /** + * Apply a Factor word to the selected word. + */ + public static void factorWordPopupOp(View view, String op) throws IOException + { + String word = factorWord(view); + if(word == null) + view.getToolkit().beep(); + else + { + new TextAreaPopup(view.getTextArea(), + evalInWire(word + " " + op).trim()); + } + } //}}} + //{{{ toWordArray() method public static FactorWord[] toWordArray(Set completions) { diff --git a/factor/jedit/FactorPlugin.props b/factor/jedit/FactorPlugin.props index 0f35839ae2..19aa62262c 100644 --- a/factor/jedit/FactorPlugin.props +++ b/factor/jedit/FactorPlugin.props @@ -46,9 +46,9 @@ factor-edit.label=Edit word at caret factor-edit-dialog.label=Edit word... factor-usages.label=Word usages at caret factor-extract-word.label=Extract word... -factor-infer-effect.label=Infer word stack effect +factor-infer-effect.label=Infer word at caret factor-compile.label=Compile word at caret -factor-infer-effects.label=Infer word stack effects +factor-infer-effects.label=Infer all words in buffer factor-restart.label=Restart Factor # SideKick stuff From 42b6d013f8faea0f89f21945e136e5e7ab9df83a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 8 Jan 2005 21:43:18 +0000 Subject: [PATCH 013/122] missing files --- library/compiler/x86/assembler.factor | 274 ++++++++++++++++++++++++++ library/compiler/x86/generator.factor | 122 ++++++++++++ 2 files changed, 396 insertions(+) create mode 100644 library/compiler/x86/assembler.factor create mode 100644 library/compiler/x86/generator.factor diff --git a/library/compiler/x86/assembler.factor b/library/compiler/x86/assembler.factor new file mode 100644 index 0000000000..1984809768 --- /dev/null +++ b/library/compiler/x86/assembler.factor @@ -0,0 +1,274 @@ +! :folding=indent:collapseFolds=1: + +! $Id$ +! +! Copyright (C) 2005 Slava Pestov. +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, +! this list of conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, +! this list of conditions and the following disclaimer in the documentation +! and/or other materials provided with the distribution. +! +! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, +! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; +! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +USE: compiler +IN: assembler +USE: words +USE: kernel +USE: parser +USE: generic +USE: lists +USE: math +USE: errors + +! A postfix assembler. +! +! x86 is a convoluted mess, so this code will be hard to +! understand unless you already know the instruction set. +! +! Syntax is: destination source opcode. For example, to add +! 3 to EAX: +! +! EAX 3 ADD +! +! The general format of an x86 instruction is: +! +! - 1-4 bytes: prefix. not supported. +! - 1-2 bytes: opcode. if the first byte is 0x0f, then opcode is +! 2 bytes. +! - 1 byte (optional): mod-r/m byte, specifying operands +! - 1/4 bytes (optional): displacement +! - 1 byte (optional): scale/index/displacement byte. not +! supported. +! - 1/4 bytes (optional): immediate operand +! +! mod-r/m has three bit fields: +! - 0-2: r/m +! - 3-5: reg +! - 6-7: mod +! +! If the direction bit (bin mask 10) in the opcode is set, then +! the source is reg, the destination is r/m. Otherwise, it is +! the opposite. x86 does this because reg can only encode a +! direct register operand, while r/m can encode other addressing +! modes in conjunction with the mod field. +! +! The mod field has this encoding: +! - BIN: 00 indirect +! - BIN: 01 1-byte displacement is present after mod-r/m field +! - BIN: 10 4-byte displacement is present after mod-r/m field +! - BIN: 11 direct register operand +! +! To encode displacement only (eg, [ 1234 ] EAX MOV), the +! r/m field stores the code for the EBP register, mod is 00, and +! a 4-byte displacement field is given. Usually if mod is 00, no +! displacement field is present. + +: byte? -128 127 between? ; + +GENERIC: modifier ( op -- mod ) +GENERIC: register ( op -- reg ) +GENERIC: displacement ( op -- ) + +( Register operands -- eg, ECX ) +: REGISTER: + CREATE dup define-symbol + scan-word "register" set-word-property ; parsing + +REGISTER: EAX 0 +REGISTER: ECX 1 +REGISTER: EDX 2 +REGISTER: EBX 3 +REGISTER: ESP 4 +REGISTER: EBP 5 +REGISTER: ESI 6 +REGISTER: EDI 7 + +PREDICATE: word register "register" word-property ; + +M: register modifier drop BIN: 11 ; +M: register register "register" word-property ; +M: register displacement drop ; + +( Indirect register operands -- eg, [ ECX ] ) +PREDICATE: list indirect + dup length 1 = [ car register? ] [ drop f ] ifte ; + +M: indirect modifier drop BIN: 00 ; +M: indirect register + car register dup BIN: 101 = [ + "x86 does not support [ EBP ]. Use [ EBP 0 ] instead." + throw + ] when ; +M: indirect displacement drop ; + +( Displaced indirect register operands -- eg, [ EAX 4 ] ) +PREDICATE: list displaced + dup length 2 = [ + 2unlist integer? swap register? and + ] [ + drop f + ] ifte ; + +M: displaced modifier cdr car byte? BIN: 01 BIN: 10 ? ; +M: displaced register car register ; +M: displaced displacement + cdr car dup byte? [ compile-byte ] [ compile-cell ] ifte ; + +( Displacement-only operands -- eg, [ 1234 ] ) +PREDICATE: list disp-only + dup length 1 = [ car integer? ] [ drop f ] ifte ; + +M: disp-only modifier drop BIN: 00 ; +M: disp-only register + #! x86 encodes displacement-only as [ EBP ]. + drop BIN: 101 ; +M: disp-only displacement + car compile-cell ; + +( Utilities ) +UNION: operand register indirect displaced disp-only ; + +: 1-operand-short ( reg n -- ) + #! Some instructions encode their single operand as part of + #! the opcode. + swap register + compile-byte ; + +: 1-operand ( op reg -- ) + >r dup modifier 6 shift over register bitor r> 3 shift bitor + compile-byte displacement ; + +: immediate-8/32 ( dst imm code reg -- ) + #! If imm is a byte, compile the opcode and the byte. + #! Otherwise, set the 32-bit operand flag in the opcode, and + #! compile the cell. The 'reg' is not really a register, but + #! a value for the 'reg' field of the mod-r/m byte. + >r over byte? [ + BIN: 10 bitor compile-byte swap r> 1-operand + compile-byte + ] [ + compile-byte swap r> 1-operand + compile-cell + ] ifte ; + +: immediate-8 ( dst imm code reg -- ) + #! The 'reg' is not really a register, but a value for the + #! 'reg' field of the mod-r/m byte. + >r compile-byte swap r> 1-operand compile-byte ; + +: 2-operand ( dst src op -- ) + #! Sets the opcode's direction bit. It is set if the + #! destination is a direct register operand. + pick register? [ BIN: 10 bitor swapd ] when + compile-byte register 1-operand ; + +: fixup ( -- addr ) + #! After compiling a jump, this returns the address where + #! the branch target can be written. + compiled-offset 4 - ; + +: relative ( addr -- addr ) + #! Relative to after next 32-bit immediate. + compiled-offset - 4 - ; + +: patch ( addr where -- ) + #! Encode a relative offset to addr from where at where. + #! Add 4 because addr is relative to *after* insn. + dup >r 4 + - r> set-compiled-cell ; + +( Moving stuff ) +GENERIC: PUSH ( op -- ) +M: register PUSH HEX: 50 1-operand-short ; +M: integer PUSH HEX: 68 compile-byte compile-cell ; +M: operand PUSH HEX: ff compile-byte BIN: 110 1-operand ; + +GENERIC: POP ( op -- ) +M: register POP HEX: 58 1-operand-short ; +M: operand POP HEX: 8f compile-byte BIN: 000 1-operand ; + +! MOV where the src is immediate. +GENERIC: (MOV-I) ( src dst -- ) +M: register (MOV-I) HEX: b8 1-operand-short compile-cell ; +M: operand (MOV-I) + HEX: c7 compile-byte 0 1-operand compile-cell ; + +GENERIC: MOV ( dst src -- ) +M: integer MOV swap (MOV-I) ; +M: operand MOV HEX: 89 2-operand ; + +( Control flow ) +GENERIC: JMP ( op -- ) +M: integer JMP HEX: e9 compile-byte relative compile-cell ; +M: operand JMP HEX: ff compile-byte BIN: 100 1-operand ; + +GENERIC: CALL ( op -- ) +M: integer CALL HEX: e8 compile-byte relative compile-cell ; +M: operand CALL HEX: ff compile-byte BIN: 010 1-operand ; + +: JUMPcc ( addr opcode -- ) + HEX: 0f compile-byte compile-byte relative compile-cell ; + +: JO HEX: 80 JUMPcc ; +: JNO HEX: 81 JUMPcc ; +: JB HEX: 82 JUMPcc ; +: JAE HEX: 83 JUMPcc ; +: JE HEX: 84 JUMPcc ; +: JNE HEX: 85 JUMPcc ; +: JBE HEX: 86 JUMPcc ; +: JA HEX: 87 JUMPcc ; +: JS HEX: 88 JUMPcc ; +: JNS HEX: 89 JUMPcc ; +: JP HEX: 8a JUMPcc ; +: JNP HEX: 8b JUMPcc ; +: JL HEX: 8c JUMPcc ; +: JGE HEX: 8d JUMPcc ; +: JLE HEX: 8e JUMPcc ; +: JG HEX: 8f JUMPcc ; + +: RET ( -- ) HEX: c3 compile-byte ; + +( Arithmetic ) + +GENERIC: ADD ( dst src -- ) +M: integer ADD HEX: 81 BIN: 000 immediate-8/32 ; +M: operand ADD HEX: 01 2-operand ; + +GENERIC: SUB ( dst src -- ) +M: integer SUB HEX: 81 BIN: 101 immediate-8/32 ; +M: operand SUB HEX: 29 2-operand ; + +: IMUL ( dst src -- ) + HEX: 0f compile-byte HEX: af 2-operand ; + +: IDIV ( src -- ) + #! IDIV is weird on x86. Only the divisor is given as an + #! explicit operand. The quotient is stored in EAX, the + #! remainder in EDX. + HEX: f7 compile-byte BIN: 111 1-operand ; + +: CDQ HEX: 99 compile-byte ; + +: SHL ( dst src -- ) HEX: c1 BIN: 100 immediate-8 ; + +: SHR ( dst src -- ) HEX: c1 BIN: 101 immediate-8 ; + +GENERIC: CMP ( dst src -- ) +M: integer CMP HEX: 81 BIN: 111 immediate-8/32 ; +M: operand CMP HEX: 39 2-operand ; + +: LEA ( dst src -- ) + HEX: 8d compile-byte swap register 1-operand ; diff --git a/library/compiler/x86/generator.factor b/library/compiler/x86/generator.factor new file mode 100644 index 0000000000..a3a03f5249 --- /dev/null +++ b/library/compiler/x86/generator.factor @@ -0,0 +1,122 @@ +! :folding=indent:collapseFolds=1: + +! $Id$ +! +! Copyright (C) 2004, 2005 Slava Pestov. +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, +! this list of conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, +! this list of conditions and the following disclaimer in the documentation +! and/or other materials provided with the distribution. +! +! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, +! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; +! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +IN: compiler +USE: alien +USE: assembler +USE: inference +USE: kernel +USE: kernel-internals +USE: lists +USE: math +USE: namespaces +USE: words + +\ slot [ + PEEK-DS + ( EAX [ EAX 3 ] MOV ) + 2unlist type-tag >r cell * r> - EAX swap 2list EAX swap MOV + [ ECX ] EAX MOV +] "generator" set-word-property + +: compile-call-label ( label -- ) + 0 CALL fixup compiled-offset defer-xt ; + +: compile-jump-label ( label -- ) + 0 JMP fixup compiled-offset defer-xt ; + +: compile-call ( word -- ) + dup dup postpone-word compile-call-label t rel-word ; + +#call [ + compile-call +] "generator" set-word-property + +#jump [ + dup dup postpone-word + compile-jump-label + t rel-word +] "generator" set-word-property + +#call-label [ + compile-call-label +] "generator" set-word-property + +#jump-label [ + compile-jump-label +] "generator" set-word-property + +#jump-t [ + POP-DS + ! condition is now in EAX + EAX f address CMP + ! jump w/ address added later + 0 JNE fixup compiled-offset defer-xt +] "generator" set-word-property + +#return-to [ + 0 PUSH fixup 0 defer-xt rel-address +] "generator" set-word-property + +#return [ drop RET ] "generator" set-word-property + +#dispatch [ + #! Compile a piece of code that jumps to an offset in a + #! jump table indexed by the fixnum at the top of the stack. + #! The jump table must immediately follow this macro. + drop + POP-DS + EAX 1 SHR + EAX HEX: ffff ADD fixup rel-address + [ EAX ] JMP + compile-aligned + compiled-offset swap set-compiled-cell ( fixup -- ) +] "generator" set-word-property + +#target [ + #! Jump table entries are absolute addresses. + compiled-offset 0 compile-cell 0 defer-xt rel-address +] "generator" set-word-property + +#c-call [ + uncons load-dll 2dup dlsym CALL t rel-dlsym +] "generator" set-word-property + +#unbox [ + dup f dlsym CALL f t rel-dlsym + EAX PUSH +] "generator" set-word-property + +#box [ + EAX PUSH + dup f dlsym CALL f t rel-dlsym + ESP 4 ADD +] "generator" set-word-property + +#cleanup [ + dup 0 = [ drop ] [ ESP swap ADD ] ifte +] "generator" set-word-property From d942a6e57c812f7d9a321f469328b4424517212c Mon Sep 17 00:00:00 2001 From: Mackenzie Straight Date: Sat, 8 Jan 2005 21:56:42 +0000 Subject: [PATCH 014/122] remove win32-console --- library/bootstrap/boot-stage2.factor | 1 - library/io/win32-console.factor | 89 ---------------------------- native/factor.h | 2 +- native/win32/ffi.c | 3 +- 4 files changed, 3 insertions(+), 92 deletions(-) delete mode 100644 library/io/win32-console.factor diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index c9b75a48b3..ed3d52e83e 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -173,7 +173,6 @@ os "win32" = [ "/library/io/win32-io-internals.factor" "/library/io/win32-stream.factor" "/library/io/win32-server.factor" - "/library/io/win32-console.factor" ] [ dup print run-resource diff --git a/library/io/win32-console.factor b/library/io/win32-console.factor deleted file mode 100644 index 1492a8d9d4..0000000000 --- a/library/io/win32-console.factor +++ /dev/null @@ -1,89 +0,0 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2004 Mackenzie Straight. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -IN: win32-console - -USE: lists -USE: vectors -USE: math -USE: kernel -USE: namespaces -USE: stdio -USE: streams -USE: presentation -USE: generic -USE: parser -USE: compiler -USE: win32-api -USE: win32-stream - -TRAITS: win32-console-stream -SYMBOL: handle - -: reset ( -- ) - handle get 7 SetConsoleTextAttribute drop ; - -: ansi>win32 ( ansi-attr -- win32-attr ) - #! Converts an ANSI color (0-based) to a combination of - #! _RED, _BLUE, and _GREEN bit flags. - { 0 4 2 6 1 5 3 7 } vector-nth ; - -: set-bold ( attr ? -- attr ) - #! Set or unset the bold bit (bit 3). - [ 8 bitor ] [ 8 bitnot bitand ] ifte ; - -: set-fg ( attr n -- attr ) - #! Set the foreground field (bits 0..2). - swap 7 bitnot bitand bitor ; - -: set-bg ( attr n -- attr ) - #! Set the background field (bits 4..6). - 4 shift swap 112 bitnot bitand bitor ; - -: char-attrs ( style -- attrs ) - #! Converts a style into a win32 text attribute bitfield. - 7 ! Default style is white FG, black BG, no extra bits - "bold" pick assoc [ set-bold ] when* - "ansi-fg" pick assoc [ str>number ansi>win32 set-fg ] when* - "ansi-bg" pick assoc [ str>number ansi>win32 set-bg ] when* - nip ; - -: set-attrs ( style -- ) - char-attrs handle get swap SetConsoleTextAttribute drop ; - -M: win32-console-stream fwrite-attr ( string style stream -- ) - [ - [ default-style ] unless* set-attrs - delegate get fwrite - reset - ] bind ; - -C: win32-console-stream ( stream -- stream ) - [ -11 GetStdHandle handle set delegate set ] extend ; - -! global [ [ ] smart-term-hook set ] bind - diff --git a/native/factor.h b/native/factor.h index 0da71d0af1..2c1d399f40 100644 --- a/native/factor.h +++ b/native/factor.h @@ -25,7 +25,7 @@ DLLEXPORT CELL ds; CELL cs_bot; /* raw pointer to callstack top */ -CELL cs; +DLLEXPORT CELL cs; #include #include diff --git a/native/win32/ffi.c b/native/win32/ffi.c index d5700da533..b438431d95 100644 --- a/native/win32/ffi.c +++ b/native/win32/ffi.c @@ -4,8 +4,9 @@ void ffi_dlopen (DLL *dll) { #ifdef FFI HMODULE module; + char *path = to_c_string(untag_string(dll->path)); - module = LoadLibrary(to_c_string(untag_string(dll->path))); + module = LoadLibrary(path); if (!module) general_error(ERROR_FFI, tag_object(last_error())); From b7d23654baf9aca557f5a6023bdd10f74f544a7d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 9 Jan 2005 18:13:26 +0000 Subject: [PATCH 015/122] removing some obsolete files --- factor/FactorCompoundDefinition.java | 54 ---------------------------- factor/FactorGenericDefinition.java | 45 ----------------------- factor/FactorSymbolDefinition.java | 50 -------------------------- factor/parser/Traits.java | 53 --------------------------- 4 files changed, 202 deletions(-) delete mode 100644 factor/FactorCompoundDefinition.java delete mode 100644 factor/FactorGenericDefinition.java delete mode 100644 factor/FactorSymbolDefinition.java delete mode 100644 factor/parser/Traits.java diff --git a/factor/FactorCompoundDefinition.java b/factor/FactorCompoundDefinition.java deleted file mode 100644 index 4f6174b833..0000000000 --- a/factor/FactorCompoundDefinition.java +++ /dev/null @@ -1,54 +0,0 @@ -/* :folding=explicit:collapseFolds=1: */ - -/* -* $Id$ -* -* Copyright (C) 2003, 2004 Slava Pestov. -* -* Redistribution and use in source and binary forms, with or without -* modification, are permitted provided that the following conditions are met: -* -* 1. Redistributions of source code must retain the above copyright notice, -* this list of conditions and the following disclaimer. -* -* 2. Redistributions in binary form must reproduce the above copyright notice, -* this list of conditions and the following disclaimer in the documentation -* and/or other materials provided with the distribution. -* -* THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -* INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -* FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -* DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -* OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -* OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -* ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*/ - -package factor; - -/** - * : name ... ; - */ -public class FactorCompoundDefinition extends FactorWordDefinition -{ - public Cons definition; - - //{{{ FactorCompoundDefinition constructor - /** - * A new definition. - */ - public FactorCompoundDefinition(FactorWord word, Cons definition) - { - super(word); - this.definition = definition; - } //}}} - - //{{{ toList() method - public Cons toList() - { - return definition; - } //}}} -} diff --git a/factor/FactorGenericDefinition.java b/factor/FactorGenericDefinition.java deleted file mode 100644 index 0794778036..0000000000 --- a/factor/FactorGenericDefinition.java +++ /dev/null @@ -1,45 +0,0 @@ -/* :folding=explicit:collapseFolds=1: */ - -/* -* $Id$ -* -* Copyright (C) 2004 Slava Pestov. -* -* Redistribution and use in source and binary forms, with or without -* modification, are permitted provided that the following conditions are met: -* -* 1. Redistributions of source code must retain the above copyright notice, -* this list of conditions and the following disclaimer. -* -* 2. Redistributions in binary form must reproduce the above copyright notice, -* this list of conditions and the following disclaimer in the documentation -* and/or other materials provided with the distribution. -* -* THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -* INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -* FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -* DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -* OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -* OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -* ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*/ - -package factor; - -/** - * GENERIC: name - */ -public class FactorGenericDefinition extends FactorWordDefinition -{ - //{{{ FactorGenericDefinition constructor - /** - * A new definition. - */ - public FactorGenericDefinition(FactorWord word) - { - super(word); - } //}}} -} diff --git a/factor/FactorSymbolDefinition.java b/factor/FactorSymbolDefinition.java deleted file mode 100644 index db9d09f341..0000000000 --- a/factor/FactorSymbolDefinition.java +++ /dev/null @@ -1,50 +0,0 @@ -/* :folding=explicit:collapseFolds=1: */ - -/* -* $Id$ -* -* Copyright (C) 2004 Slava Pestov. -* -* Redistribution and use in source and binary forms, with or without -* modification, are permitted provided that the following conditions are met: -* -* 1. Redistributions of source code must retain the above copyright notice, -* this list of conditions and the following disclaimer. -* -* 2. Redistributions in binary form must reproduce the above copyright notice, -* this list of conditions and the following disclaimer in the documentation -* and/or other materials provided with the distribution. -* -* THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -* INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -* FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -* DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -* OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -* OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -* ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*/ - -package factor; - -/** - * SYMBOL: name - * - * Pushes word named. - */ -public class FactorSymbolDefinition extends FactorWordDefinition -{ - public Object symbol; - - //{{{ FactorSymbolDefinition constructor - /** - * A new definition. - */ - public FactorSymbolDefinition(FactorWord word, Object symbol) - { - super(word); - this.symbol = symbol; - } //}}} -} diff --git a/factor/parser/Traits.java b/factor/parser/Traits.java deleted file mode 100644 index 31f9512f50..0000000000 --- a/factor/parser/Traits.java +++ /dev/null @@ -1,53 +0,0 @@ -/* :folding=explicit:collapseFolds=1: */ - -/* - * $Id$ - * - * Copyright (C) 2004 Slava Pestov. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * 1. Redistributions of source code must retain the above copyright notice, - * this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND - * FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE - * DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; - * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, - * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR - * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF - * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - */ - -package factor.parser; - -import factor.*; - -public class Traits extends FactorParsingDefinition -{ - public Traits(FactorWord word) - { - super(word); - } - - public void eval(FactorReader reader) - throws Exception - { - FactorWord w = reader.nextWord(true); - if(w == null) - return; - - w.def = new FactorTraitsDefinition(w); - reader.intern("<" + w.name + ">",true); - reader.intern(w.name + "?",true); - reader.append(w.def); - } -} From d236dd9ec8ea75faf887fe3cfc00053470947610 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 11 Jan 2005 04:08:27 +0000 Subject: [PATCH 016/122] making a mess of type inference; fixing overflowing /mod --- TODO.FACTOR.txt | 34 ++++++---- library/bootstrap/image.factor | 2 +- library/compiler/x86/assembler.factor | 6 +- library/compiler/x86/fixnum.factor | 2 +- library/inference/branches.factor | 18 +++--- library/inference/inference.factor | 28 ++++++-- library/inference/words.factor | 93 ++++++++++++++++++++++----- library/test/inference.factor | 40 ++++++++---- library/test/vectors.factor | 2 +- library/vectors.factor | 16 ++++- 10 files changed, 175 insertions(+), 66 deletions(-) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 8aa8c2b966..86e5218c39 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,10 +1,16 @@ + compiler: -- type inference fails with some assembler words -- more accurate type inference in some cases +- investigate why : foo t or ; doesn't partially evaluate +- investigate why ' doesn't infer +- recursive? and tree-contains? should handle vectors +- type inference and recursion flaw +- type inference fails with some assembler words; + displaced, register and other predicates need to inherit from list + not cons, and need stronger branch partial eval +- more accurate type inference in some cases - optimize away dispatch -- goal: to compile hash* optimally -- type check/not-check entry points for compiled words +- goal: to compile hash* optimally +- type check/not-check entry points for compiled words - getenv/setenv: if literal arg, compile as a load/store + oop: @@ -23,33 +29,39 @@ + listener/plugin: +- update plugin docs +- extract word keeps indent +- word preview for remote words - WordPreview calls markTokens() -> NPE -- stream server can hang because of exception handler limitations - listener should be multithreaded -- compile all, infer all commands +- compile all commands - faster completion -- errors don't always disappear - NPE in ErrorHighlight - maple-like: press enter at old commands to evaluate there - completion in the listener - special completion for USE:/IN: ++ i/o: + +- stream server can hang because of exception handler limitations +- better i/o scheduler +- nicer way to combine two paths +- add a socket timeout +- rename f* words to stream-* +- is badly named -- , + + kernel: - ppc register decls - do partial objects cause problems? -- better i/o scheduler - remove sbufs - cat, reverse-cat primitives - first-class hashtables -- add a socket timeout + misc: - perhaps /i should work with all numbers -- unit test weirdness: 2 lines appears at end - jedit ==> jedit-word, jedit takes a file name -- nicer way to combine two paths - browser responder for word links in HTTPd - worddef props - prettyprint: when unparse called due to recursion, write a link diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index 0fcbe52aae..063d21bbfb 100644 --- a/library/bootstrap/image.factor +++ b/library/bootstrap/image.factor @@ -215,7 +215,7 @@ M: f ' ( obj -- ptr ) : transfer-word ( word -- word ) #! This is a hack. See doc/bootstrap.txt. dup dup word-name swap word-vocabulary unit search - [ "Missing DEFER: " word-error ] ?unless ; + [ dup "Missing DEFER: " word-error ] ?unless ; : fixup-word ( word -- offset ) dup pooled-object [ "Not in image: " word-error ] ?unless ; diff --git a/library/compiler/x86/assembler.factor b/library/compiler/x86/assembler.factor index 1984809768..01e8f8d91c 100644 --- a/library/compiler/x86/assembler.factor +++ b/library/compiler/x86/assembler.factor @@ -105,7 +105,7 @@ M: register register "register" word-property ; M: register displacement drop ; ( Indirect register operands -- eg, [ ECX ] ) -PREDICATE: list indirect +PREDICATE: cons indirect dup length 1 = [ car register? ] [ drop f ] ifte ; M: indirect modifier drop BIN: 00 ; @@ -117,7 +117,7 @@ M: indirect register M: indirect displacement drop ; ( Displaced indirect register operands -- eg, [ EAX 4 ] ) -PREDICATE: list displaced +PREDICATE: cons displaced dup length 2 = [ 2unlist integer? swap register? and ] [ @@ -130,7 +130,7 @@ M: displaced displacement cdr car dup byte? [ compile-byte ] [ compile-cell ] ifte ; ( Displacement-only operands -- eg, [ 1234 ] ) -PREDICATE: list disp-only +PREDICATE: cons disp-only dup length 1 = [ car integer? ] [ drop f ] ifte ; M: disp-only modifier drop BIN: 00 ; diff --git a/library/compiler/x86/fixnum.factor b/library/compiler/x86/fixnum.factor index cdc1f6dd61..b8e341897b 100644 --- a/library/compiler/x86/fixnum.factor +++ b/library/compiler/x86/fixnum.factor @@ -135,7 +135,7 @@ USE: math-internals [ ECX ] IDIV EAX 3 SHL 0 JNO fixup - \ fixnum/i compile-call + \ fixnum/mod compile-call 0 JMP fixup >r compiled-offset swap patch [ ECX -4 ] EAX MOV diff --git a/library/inference/branches.factor b/library/inference/branches.factor index 3e725e40e1..bf66244b2d 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -47,7 +47,7 @@ USE: prettyprint : add-inputs ( count stack -- stack ) #! Add this many inputs to the given stack. - dup >r vector-length - computed-value-vector dup r> + [ vector-length - computed-value-vector ] keep vector-append ; : unify-lengths ( list -- list ) @@ -89,7 +89,7 @@ USE: prettyprint ] ifte ; : datastack-effect ( list -- ) - [ [ d-in get meta-d get ] bind cons ] map + [ [ effect ] bind ] map unify-effect meta-d set d-in set ; @@ -161,7 +161,7 @@ SYMBOL: cloned #! for the given branch. [ [ - inferring-base-case get [ + branches-can-fail? [ [ infer-branch , ] [ @@ -182,7 +182,7 @@ SYMBOL: cloned #! the branches has an undecidable stack effect, we set the #! base case to this stack effect and try again. The inputs #! parameter is a vector. - (infer-branches) dup unify-effects unify-dataflow ; + (infer-branches) dup unify-effects unify-dataflow ; : (with-block) ( label quot -- ) #! Call a quotation in a new namespace, and transfer @@ -196,7 +196,7 @@ SYMBOL: cloned meta-r set meta-d set d-in set ; : static-branch? ( value -- ) - literal? inferring-base-case get not and ; + literal? branches-can-fail? not and ; : static-ifte ( true false -- ) #! If the branch taken is statically known, just infer @@ -222,11 +222,11 @@ SYMBOL: cloned [ object general-list general-list ] ensure-d dataflow-drop, pop-d dataflow-drop, pop-d swap -! peek-d static-branch? [ -! static-ifte -! ] [ + peek-d static-branch? [ + static-ifte + ] [ dynamic-ifte - ( ] ifte ) ; + ] ifte ; \ ifte [ infer-ifte ] "infer" set-word-property diff --git a/library/inference/inference.factor b/library/inference/inference.factor index 2ee4c4c9b8..02dd8fda87 100644 --- a/library/inference/inference.factor +++ b/library/inference/inference.factor @@ -39,10 +39,18 @@ USE: hashtables USE: generic USE: prettyprint -! If this symbol is on, partial evalution of conditionals is +! If this variable is on, partial evalution of conditionals is ! disabled. SYMBOL: inferring-base-case +! If this variable is on, we are inferring the entry effect, so +! we unify all entry point effects to the vecto stored in this +! variable. +SYMBOL: inferring-entry-effect + +: branches-can-fail? ( -- ? ) + inferring-base-case get inferring-entry-effect get or ; + ! Word properties that affect inference: ! - infer-effect -- must be set. controls number of inputs ! expected, and number of outputs produced. @@ -130,7 +138,7 @@ M: literal set-value-class ( class value -- ) ] ifte ; : vector-prepend ( values stack -- stack ) - >r list>vector dup r> vector-append ; + >r list>vector r> vector-append ; : ensure-d ( typelist -- ) dup meta-d get ensure-types @@ -138,17 +146,23 @@ M: literal set-value-class ( class value -- ) meta-d [ vector-prepend ] change d-in [ vector-prepend ] change ; -: effect ( -- [ in-types out-types ] ) +: (present-effect) ( vector -- list ) + [ value-class ] vector-map vector>list ; + +: present-effect ( [ d-in | meta-d ] -- [ in-types out-types ] ) #! After inference is finished, collect information. - d-in get [ value-class ] vector-map vector>list - meta-d get [ value-class ] vector-map vector>list 2list ; + uncons >r (present-effect) r> (present-effect) 2list ; + +: effect ( -- [ d-in | meta-d ] ) + d-in get meta-d get cons ; : init-inference ( recursive-state -- ) init-interpreter 0 d-in set recursive-state set dataflow-graph off - inferring-base-case off ; + inferring-base-case off + inferring-entry-effect off ; DEFER: apply-word @@ -186,7 +200,7 @@ DEFER: apply-word : infer ( quot -- [ in | out ] ) #! Stack effect of a quotation. - [ (infer) effect ] with-scope ; + [ (infer) effect present-effect ] with-scope ; : dataflow ( quot -- dataflow ) #! Data flow of a quotation. diff --git a/library/inference/words.factor b/library/inference/words.factor index cc013eb1ed..9d870bf80d 100644 --- a/library/inference/words.factor +++ b/library/inference/words.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2004 Slava Pestov. +! Copyright (C) 2004, 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -88,17 +88,32 @@ USE: prettyprint r> call ] (with-block) ; +: entry-effect ( quot -- ) + [ + meta-d get inferring-entry-effect set + copy-inference + infer-quot + inferring-entry-effect off + ] with-scope ; + +: recursive? ( word -- ? ) + dup word-parameter tree-contains? ; + : inline-compound ( word -- effect ) #! Infer the stack effect of a compound word in the current - #! inferencer instance. - gensym [ word-parameter infer-quot effect ] with-block ; + #! inferencer instance. If the word in question is recursive + #! we infer its stack effect inside a new block. + gensym [ + dup recursive? [ dup word-parameter entry-effect ] when + word-parameter infer-quot effect + ] with-block ; : infer-compound ( word -- effect ) #! Infer a word's stack effect in a separate inferencer #! instance. [ recursive-state get init-inference - dup dup inline-compound + dup dup inline-compound present-effect [ "infer-effect" set-word-property ] keep ] with-scope consume/produce ; @@ -135,32 +150,77 @@ M: symbol (apply-word) ( word -- ) ] when ] when ; -: decompose ( x y -- effect ) +: decompose ( x y -- [ d-in | meta-d ] ) #! Return a stack effect such that x*effect = y. - 2unlist >r - swap 2unlist >r - over length over length - head nip - r> append - r> 2list ; + uncons >r swap uncons >r + over vector-length over vector-length - + swap vector-head nip + r> vector-append r> cons ; -: base-case ( word -- effect ) - effect swap +: base-case ( word -- [ d-in | meta-d ] ) [ inferring-base-case on copy-inference inline-compound inferring-base-case off - ] with-scope decompose ; + ] with-scope effect swap decompose ; + +: no-base-case ( word -- ) + word-name " does not have a base case." cat2 throw ; + +: raise# ( n vec -- n ) + #! Parameter is a vector of pairs. Return the highest index + #! where pairs are equal. + 2dup vector-length >= [ + drop + ] [ + 2dup vector-nth uncons = [ + >r 1 + r> raise# + ] [ + drop + ] ifte + ] ifte ; + +: raise ( vec1 vec2 -- list ) + #! Return a new vector consisting of the remainder of vec1, + #! without any leading elements equal to those from vec2. + over vector-zip 0 swap raise# swap vector-tail ; + +: unify-entry-effect ( vector list -- ) + #! If any elements are not equal, the vector's element is + #! replaced with the list's. + over vector-length over length - -rot [ + ( n vector elt ) + pick pick vector-nth over = [ + drop + ] [ + pick pick set-vector-nth + ] ifte + >r 1 + r> + ] each 2drop ; + +: apply-entry-effect ( word -- ) + #! Called at a recursive call point. We need this to compute + #! the set of literals that is retained across a recursive + #! call -- this is NOT the same as the literals present on + #! entry. This word mutates the inferring-entry-effect + #! vector. + base-case uncons raise + inferring-entry-effect get swap unify-entry-effect ; : recursive-word ( word label -- ) #! Handle a recursive call, by either applying a previously #! inferred base case, or raising an error. If the recursive #! call is to a local block, emit a label call node. inferring-base-case get [ - drop word-name " does not have a base case." cat2 throw + drop no-base-case ] [ - 2dup [ drop #call-label ] [ nip #call ] ifte - rot base-case (consume/produce) + inferring-entry-effect get [ + apply-entry-effect "Bail out" throw + ] [ + dup [ #call-label ] [ #call ] ?ifte + rot base-case present-effect (consume/produce) + ] ifte ] ifte ; : apply-word ( word -- ) @@ -186,6 +246,7 @@ M: symbol (apply-word) ( word -- ) \ call [ infer-call ] "infer" set-word-property +! These hacks will go away soon \ * [ [ number number ] [ number ] ] "infer-effect" set-word-property \ undefined-method t "terminator" set-word-property diff --git a/library/test/inference.factor b/library/test/inference.factor index bd4534aca8..af754a2219 100644 --- a/library/test/inference.factor +++ b/library/test/inference.factor @@ -11,23 +11,35 @@ USE: kernel USE: math-internals USE: generic -[ [ [ object object ] f ] ] -[ [ [ object ] [ object object ] ] [ [ object ] f ] decompose ] +[ 0 ] +[ { 1 2 3 } { 4 5 6 } vector-zip 0 swap raise# ] unit-test -[ [ [ cons vector cons integer object cons ] [ cons vector cons ] ] ] -[ - [ [ vector ] [ cons vector cons integer object cons ] ] - [ [ vector ] [ cons vector cons ] ] - decompose -] unit-test +[ 2 ] +[ { 1 2 3 } { 1 2 6 } vector-zip 0 swap raise# ] +unit-test -[ [ [ object ] [ object ] ] ] -[ - [ [ object number ] [ object ] ] - [ [ object number ] [ object ] ] - decompose -] unit-test +[ { 4 5 6 } ] +[ { 1 2 3 } dup [ 4 5 6 ] unify-entry-effect ] +unit-test + +! [ [ [ object object ] f ] ] +! [ [ [ object ] [ object object ] ] [ [ object ] f ] decompose ] +! unit-test +! +! [ [ [ cons vector cons integer object cons ] [ cons vector cons ] ] ] +! [ +! [ [ vector ] [ cons vector cons integer object cons ] ] +! [ [ vector ] [ cons vector cons ] ] +! decompose +! ] unit-test +! +! [ [ [ object ] [ object ] ] ] +! [ +! [ [ object number ] [ object ] ] +! [ [ object number ] [ object ] ] +! decompose +! ] unit-test : old-effect ( [ in-types out-types ] -- [ in | out ] ) uncons car length >r length r> cons ; diff --git a/library/test/vectors.factor b/library/test/vectors.factor index 4cb177480e..7a9a2e1a3b 100644 --- a/library/test/vectors.factor +++ b/library/test/vectors.factor @@ -50,7 +50,7 @@ USE: namespaces [ t ] [ { } hashcode { } hashcode = ] unit-test [ { 1 2 3 4 5 6 } ] -[ { 1 2 3 } vector-clone dup { 4 5 6 } vector-append ] unit-test +[ { 1 2 3 } { 4 5 6 } vector-append ] unit-test [ { "" "a" "aa" "aaa" } ] [ 4 [ CHAR: a fill ] vector-project ] diff --git a/library/vectors.factor b/library/vectors.factor index 93e9e7d7d0..25c87c0b49 100644 --- a/library/vectors.factor +++ b/library/vectors.factor @@ -107,10 +107,15 @@ BUILTIN: vector 11 : vector-all? ( vector pred -- ? ) vector-map vector-and ; inline -: vector-append ( v1 v2 -- ) +: vector-nappend ( v1 v2 -- ) #! Destructively append v2 to v1. [ over vector-push ] vector-each drop ; +: vector-append ( v1 v2 -- vec ) + over vector-length over vector-length + + [ rot vector-nappend ] keep + [ swap vector-nappend ] keep ; + : vector-project ( n quot -- accum ) #! Execute the quotation n times, passing the loop counter #! the quotation as it ranges from 0..n-1. Collect results @@ -122,7 +127,7 @@ BUILTIN: vector 11 : vector-zip ( v1 v2 -- v ) #! Make a new vector with each pair of elements from the #! first two in a pair. - over vector-length [ + over vector-length over vector-length min [ pick pick >r over >r vector-nth r> r> vector-nth cons ] vector-project nip nip ; @@ -168,8 +173,13 @@ M: vector hashcode ( vec -- n ) over ?vector-nth hashcode rot bitxor swap ] times* drop ; +: vector-head ( n vector -- list ) + #! Return a new list with all elements up to the nth + #! element. + swap [ over vector-nth ] vector-project nip ; + : vector-tail ( n vector -- list ) - #! Return a new vector, with all elements from the nth + #! Return a new list with all elements from the nth #! index upwards. 2dup vector-length swap - [ pick + over vector-nth From 8615910885a080a0a5e8dd2af40677c18afc2453 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Jan 2005 19:41:08 +0000 Subject: [PATCH 017/122] entry effect code work --- library/bootstrap/boot-stage2.factor | 3 +- library/bootstrap/boot.factor | 3 +- library/generic/complement.factor | 76 ++++++++++++++++++++++++++++ library/generic/generic.factor | 1 + library/generic/union.factor | 4 +- library/inference/branches.factor | 22 ++++++-- library/inference/words.factor | 13 ++--- library/kernel.factor | 3 +- library/lists.factor | 5 ++ library/primitives.factor | 4 +- library/test/generic.factor | 6 +++ library/test/inference.factor | 6 +++ library/test/lists/lists.factor | 2 + 13 files changed, 130 insertions(+), 18 deletions(-) create mode 100644 library/generic/complement.factor diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index ed3d52e83e..444780df70 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2004 Slava Pestov. +! Copyright (C) 2004, 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -45,6 +45,7 @@ USE: namespaces "/library/generic/builtin.factor" "/library/generic/predicate.factor" "/library/generic/union.factor" + "/library/generic/complement.factor" "/library/generic/traits.factor" "/version.factor" diff --git a/library/bootstrap/boot.factor b/library/bootstrap/boot.factor index 2070c16fde..71cafa7b49 100644 --- a/library/bootstrap/boot.factor +++ b/library/bootstrap/boot.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2004 Slava Pestov. +! Copyright (C) 2004, 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -86,6 +86,7 @@ USE: hashtables "/library/generic/builtin.factor" parse-resource append, "/library/generic/predicate.factor" parse-resource append, "/library/generic/union.factor" parse-resource append, + "/library/generic/complement.factor" parse-resource append, "/library/generic/traits.factor" parse-resource append, "/library/bootstrap/init.factor" parse-resource append, diff --git a/library/generic/complement.factor b/library/generic/complement.factor new file mode 100644 index 0000000000..e0014b1666 --- /dev/null +++ b/library/generic/complement.factor @@ -0,0 +1,76 @@ +! :folding=indent:collapseFolds=1: + +! $Id$ +! +! Copyright (C) 2005 Slava Pestov. +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, +! this list of conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, +! this list of conditions and the following disclaimer in the documentation +! and/or other materials provided with the distribution. +! +! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, +! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; +! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +IN: generic +USE: errors +USE: hashtables +USE: kernel +USE: lists +USE: namespaces +USE: parser +USE: strings +USE: words +USE: vectors +USE: math + +! Complement metaclass, contains all objects not in a certain class. +SYMBOL: complement + +complement [ + "complement" word-property builtin-supertypes + num-types count + difference +] "builtin-supertypes" set-word-property + +complement [ + ( generic vtable definition class -- ) + drop num-types [ >r 3dup r> add-method ] times* 3drop +] "add-method" set-word-property + +complement 90 "priority" set-word-property + +complement [ + swap "complement" word-property + swap "complement" word-property + class< not +] "class<" set-word-property + +: complement-predicate ( complement -- list ) + "predicate" word-property [ not ] append ; + +: define-complement ( class predicate complement -- ) + [ complement-predicate define-compound ] keep + dupd "complement" set-word-property + complement define-class ; + +: COMPLEMENT: ( -- class predicate definition ) + #! Followed by a class name, then a complemented class. + CREATE + dup intern-symbol + dup predicate-word + [ dupd unit "predicate" set-word-property ] keep + scan-word define-complement ; parsing diff --git a/library/generic/generic.factor b/library/generic/generic.factor index 5914b660ff..fa3062bf72 100644 --- a/library/generic/generic.factor +++ b/library/generic/generic.factor @@ -80,6 +80,7 @@ USE: math-internals : class-ord ( class -- n ) metaclass "priority" word-property ; : class< ( cls1 cls2 -- ? ) + #! Test if class1 is a subclass of class2. over metaclass over metaclass = [ dup metaclass "class<" word-property call ] [ diff --git a/library/generic/union.factor b/library/generic/union.factor index a90ce324ef..1bcf11cfa8 100644 --- a/library/generic/union.factor +++ b/library/generic/union.factor @@ -78,13 +78,13 @@ union [ 2drop t ] "class<" set-word-property ] keep ? ] map [ union-predicate define-compound ] keep - "members" set-word-property ; + dupd "members" set-word-property + union define-class ; : UNION: ( -- class predicate definition ) #! Followed by a class name, then a list of union members. CREATE dup intern-symbol - dup union define-class dup predicate-word [ dupd unit "predicate" set-word-property ] keep [ define-union ] [ ] ; parsing diff --git a/library/inference/branches.factor b/library/inference/branches.factor index bf66244b2d..60e107047a 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2004 Slava Pestov. +! Copyright (C) 2004, 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -195,13 +195,25 @@ SYMBOL: cloned r> swap #label dataflow, [ node-label set ] bind meta-r set meta-d set d-in set ; -: static-branch? ( value -- ) - literal? branches-can-fail? not and ; +: boolean-value? ( value -- ? ) + #! Return if the value's boolean valuation is known. + value-class + dup \ f = swap + builtin-supertypes + \ f builtin-supertypes intersection not + or ; + +: boolean-value ( value -- ? ) + #! Only valid if boolean? returns true. + value-class \ f = not ; + +: static-branch? ( value -- ? ) + boolean-value? branches-can-fail? not and ; : static-ifte ( true false -- ) #! If the branch taken is statically known, just infer #! along that branch. - dataflow-drop, pop-d literal-value [ drop ] [ nip ] ifte + dataflow-drop, pop-d boolean-value [ drop ] [ nip ] ifte gensym [ dup value-recursion recursive-state set literal-value infer-quot @@ -212,7 +224,7 @@ SYMBOL: cloned #! unify. 2list >r 1 meta-d get vector-tail* #ifte r> pop-d [ - dup \ object cons , + dup \ general-t cons , \ f cons , ] make-list zip ( condition ) infer-branches ; diff --git a/library/inference/words.factor b/library/inference/words.factor index 9d870bf80d..d68ee4fee6 100644 --- a/library/inference/words.factor +++ b/library/inference/words.factor @@ -199,14 +199,16 @@ M: symbol (apply-word) ( word -- ) >r 1 + r> ] each 2drop ; -: apply-entry-effect ( word -- ) +: (recursive-word) ( word label effect -- ) + >r [ #call-label ] [ #call ] ?ifte r> (consume/produce) ; + +: apply-entry-effect ( word label -- ) #! Called at a recursive call point. We need this to compute #! the set of literals that is retained across a recursive #! call -- this is NOT the same as the literals present on #! entry. This word mutates the inferring-entry-effect #! vector. - base-case uncons raise - inferring-entry-effect get swap unify-entry-effect ; + over base-case uncons raise present-effect (recursive-word) ; : recursive-word ( word label -- ) #! Handle a recursive call, by either applying a previously @@ -216,10 +218,9 @@ M: symbol (apply-word) ( word -- ) drop no-base-case ] [ inferring-entry-effect get [ - apply-entry-effect "Bail out" throw + apply-entry-effect ] [ - dup [ #call-label ] [ #call ] ?ifte - rot base-case present-effect (consume/produce) + over base-case present-effect (recursive-word) ] ifte ] ifte ; diff --git a/library/kernel.factor b/library/kernel.factor index 516a671cfd..1b305dbb78 100644 --- a/library/kernel.factor +++ b/library/kernel.factor @@ -67,7 +67,7 @@ M: object = eq? ; : and ( a b -- a&b ) f ? ; inline : not ( a -- ~a ) f t ? ; inline -: or ( a b -- a|b) t swap ? ; inline +: or ( a b -- a|b ) t swap ? ; inline : xor ( a b -- a^b ) dup not swap ? ; inline IN: syntax @@ -76,3 +76,4 @@ BUILTIN: t 7 IN: kernel UNION: boolean f t ; +COMPLEMENT: general-t f diff --git a/library/lists.factor b/library/lists.factor index 0fc947aa64..7cab567d56 100644 --- a/library/lists.factor +++ b/library/lists.factor @@ -209,3 +209,8 @@ M: cons hashcode ( cons -- hash ) 4 cons-hashcode ; : intersection ( list list -- list ) #! Make a list of elements that occur in both lists. [ over contains? ] subset nip ; + +: difference ( list1 list2 -- list ) + #! Make a list of elements that occur in list2 but not + #! list1. + [ over contains? not ] subset nip ; diff --git a/library/primitives.factor b/library/primitives.factor index be4dc0914e..92b827dd0b 100644 --- a/library/primitives.factor +++ b/library/primitives.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2004 Slava Pestov. +! Copyright (C) 2004, 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -74,7 +74,7 @@ USE: words [ sbuf-clone [ [ sbuf ] [ sbuf ] ] ] [ sbuf= [ [ sbuf sbuf ] [ boolean ] ] ] [ sbuf-hashcode [ [ sbuf ] [ fixnum ] ] ] - [ arithmetic-type [ [ number number ] [ number number fixnum ] ] ] + [ arithmetic-type [ [ object object ] [ object object fixnum ] ] ] [ >fixnum [ [ number ] [ fixnum ] ] ] [ >bignum [ [ number ] [ bignum ] ] ] [ >float [ [ number ] [ float ] ] ] diff --git a/library/test/generic.factor b/library/test/generic.factor index d55899ffa1..404f513466 100644 --- a/library/test/generic.factor +++ b/library/test/generic.factor @@ -8,6 +8,7 @@ USE: math USE: words USE: lists USE: vectors +USE: alien TRAITS: test-traits C: test-traits ; @@ -145,3 +146,8 @@ M: very-funny gooey sq ; [ t ] [ \ generic \ compound class< ] unit-test [ f ] [ \ compound \ generic class< ] unit-test + +DEFER: bah +FORGET: bah +UNION: bah fixnum alien ; +[ bah ] [ fixnum alien class-or ] unit-test diff --git a/library/test/inference.factor b/library/test/inference.factor index af754a2219..b20194370a 100644 --- a/library/test/inference.factor +++ b/library/test/inference.factor @@ -234,3 +234,9 @@ SYMBOL: sym-test ! [ [ [ number ] [ number ] ] ] [ [ dup + ] infer ] unit-test ! [ [ [ number number number ] [ number ] ] ] [ [ digit+ ] infer ] unit-test [ [ [ number ] [ real real ] ] ] [ [ >rect ] infer ] unit-test + +[ [ [ ] [ POSTPONE: t ] ] ] [ [ f not ] infer ] unit-test +[ [ [ ] [ POSTPONE: f ] ] ] [ [ t not ] infer ] unit-test +[ [ [ ] [ POSTPONE: f ] ] ] [ [ 5 not ] infer ] unit-test + +[ [ [ object ] [ general-t ] ] ] [ [ dup [ not ] unless ] infer ] unit-test diff --git a/library/test/lists/lists.factor b/library/test/lists/lists.factor index d0ce247a65..232893f90c 100644 --- a/library/test/lists/lists.factor +++ b/library/test/lists/lists.factor @@ -60,3 +60,5 @@ USE: strings [ [ 1 ] ] [ [ 1 ] 1 head ] unit-test [ [ 1 ] 2 head ] unit-test-fails [ [ 1 2 3 ] ] [ [ 1 2 3 4 ] 3 head ] unit-test + +[ [ 1 3 ] ] [ [ 2 ] [ 1 2 3 ] difference ] unit-test From 242644a236f2488f5935bcb47f31f02ef1623eb6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Jan 2005 22:28:29 +0000 Subject: [PATCH 018/122] finally fix vector-and compilation --- library/bootstrap/boot-stage2.factor | 1 - library/bootstrap/boot.factor | 1 - library/httpd/url-encoding.factor | 1 + library/inference/branches.factor | 2 +- library/inference/inference.factor | 17 ++---- library/inference/test.factor | 1 + library/inference/words.factor | 87 ++++++++-------------------- library/list-namespaces.factor | 65 --------------------- library/namespaces.factor | 38 ++++++++++++ library/primitives.factor | 2 +- library/syntax/see.factor | 1 + library/test/inference.factor | 16 +---- 12 files changed, 75 insertions(+), 157 deletions(-) delete mode 100644 library/list-namespaces.factor diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index 444780df70..eb605a9ec8 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -66,7 +66,6 @@ USE: namespaces "/library/strings.factor" "/library/hashtables.factor" "/library/namespaces.factor" - "/library/list-namespaces.factor" "/library/sbuf.factor" "/library/errors.factor" "/library/continuations.factor" diff --git a/library/bootstrap/boot.factor b/library/bootstrap/boot.factor index 71cafa7b49..380948ced2 100644 --- a/library/bootstrap/boot.factor +++ b/library/bootstrap/boot.factor @@ -57,7 +57,6 @@ USE: hashtables "/library/strings.factor" parse-resource append, "/library/hashtables.factor" parse-resource append, "/library/namespaces.factor" parse-resource append, - "/library/list-namespaces.factor" parse-resource append, "/library/sbuf.factor" parse-resource append, "/library/errors.factor" parse-resource append, "/library/continuations.factor" parse-resource append, diff --git a/library/httpd/url-encoding.factor b/library/httpd/url-encoding.factor index 0993a14cfa..bada6ff4fa 100644 --- a/library/httpd/url-encoding.factor +++ b/library/httpd/url-encoding.factor @@ -30,6 +30,7 @@ USE: errors USE: kernel USE: lists USE: math +USE: namespaces USE: parser USE: strings USE: unparser diff --git a/library/inference/branches.factor b/library/inference/branches.factor index 60e107047a..a01924c3dd 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -161,7 +161,7 @@ SYMBOL: cloned #! for the given branch. [ [ - branches-can-fail? [ + inferring-base-case get 0 > [ [ infer-branch , ] [ diff --git a/library/inference/inference.factor b/library/inference/inference.factor index 02dd8fda87..1df0f2199b 100644 --- a/library/inference/inference.factor +++ b/library/inference/inference.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2004 Slava Pestov. +! Copyright (C) 2004, 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -39,17 +39,13 @@ USE: hashtables USE: generic USE: prettyprint -! If this variable is on, partial evalution of conditionals is -! disabled. +: max-recursion 1 ; + +! This variable takes a value from 0 up to max-recursion. SYMBOL: inferring-base-case -! If this variable is on, we are inferring the entry effect, so -! we unify all entry point effects to the vecto stored in this -! variable. -SYMBOL: inferring-entry-effect - : branches-can-fail? ( -- ? ) - inferring-base-case get inferring-entry-effect get or ; + inferring-base-case get max-recursion >= ; ! Word properties that affect inference: ! - infer-effect -- must be set. controls number of inputs @@ -161,8 +157,7 @@ M: literal set-value-class ( class value -- ) 0 d-in set recursive-state set dataflow-graph off - inferring-base-case off - inferring-entry-effect off ; + 0 inferring-base-case set ; DEFER: apply-word diff --git a/library/inference/test.factor b/library/inference/test.factor index 9cbd8166d3..6f325eb54f 100644 --- a/library/inference/test.factor +++ b/library/inference/test.factor @@ -30,6 +30,7 @@ USE: errors USE: inference USE: kernel USE: lists +USE: namespaces USE: prettyprint USE: stdio USE: strings diff --git a/library/inference/words.factor b/library/inference/words.factor index d68ee4fee6..9d77cd54b2 100644 --- a/library/inference/words.factor +++ b/library/inference/words.factor @@ -88,14 +88,6 @@ USE: prettyprint r> call ] (with-block) ; -: entry-effect ( quot -- ) - [ - meta-d get inferring-entry-effect set - copy-inference - infer-quot - inferring-entry-effect off - ] with-scope ; - : recursive? ( word -- ? ) dup word-parameter tree-contains? ; @@ -103,10 +95,7 @@ USE: prettyprint #! Infer the stack effect of a compound word in the current #! inferencer instance. If the word in question is recursive #! we infer its stack effect inside a new block. - gensym [ - dup recursive? [ dup word-parameter entry-effect ] when - word-parameter infer-quot effect - ] with-block ; + gensym [ word-parameter infer-quot effect ] with-block ; : infer-compound ( word -- effect ) #! Infer a word's stack effect in a separate inferencer @@ -157,70 +146,42 @@ M: symbol (apply-word) ( word -- ) swap vector-head nip r> vector-append r> cons ; +: with-recursion ( quot -- ) + [ + inferring-base-case inc + call + ] [ + inferring-base-case dec + rethrow + ] catch ; + : base-case ( word -- [ d-in | meta-d ] ) [ - inferring-base-case on - copy-inference - inline-compound - inferring-base-case off - ] with-scope effect swap decompose ; + [ + copy-inference + inline-compound + ] with-scope effect swap decompose + present-effect + >r [ #call-label ] [ #call ] ?ifte r> + (consume/produce) + ] with-recursion ; : no-base-case ( word -- ) word-name " does not have a base case." cat2 throw ; -: raise# ( n vec -- n ) - #! Parameter is a vector of pairs. Return the highest index - #! where pairs are equal. - 2dup vector-length >= [ - drop - ] [ - 2dup vector-nth uncons = [ - >r 1 + r> raise# - ] [ - drop - ] ifte - ] ifte ; - -: raise ( vec1 vec2 -- list ) - #! Return a new vector consisting of the remainder of vec1, - #! without any leading elements equal to those from vec2. - over vector-zip 0 swap raise# swap vector-tail ; - -: unify-entry-effect ( vector list -- ) - #! If any elements are not equal, the vector's element is - #! replaced with the list's. - over vector-length over length - -rot [ - ( n vector elt ) - pick pick vector-nth over = [ - drop - ] [ - pick pick set-vector-nth - ] ifte - >r 1 + r> - ] each 2drop ; - -: (recursive-word) ( word label effect -- ) - >r [ #call-label ] [ #call ] ?ifte r> (consume/produce) ; - -: apply-entry-effect ( word label -- ) - #! Called at a recursive call point. We need this to compute - #! the set of literals that is retained across a recursive - #! call -- this is NOT the same as the literals present on - #! entry. This word mutates the inferring-entry-effect - #! vector. - over base-case uncons raise present-effect (recursive-word) ; - : recursive-word ( word label -- ) #! Handle a recursive call, by either applying a previously #! inferred base case, or raising an error. If the recursive #! call is to a local block, emit a label call node. - inferring-base-case get [ + inferring-base-case get max-recursion > [ drop no-base-case ] [ - inferring-entry-effect get [ - apply-entry-effect + inferring-base-case get max-recursion = [ + over base-case ] [ - over base-case present-effect (recursive-word) + [ + drop inline-compound drop + ] with-recursion ] ifte ] ifte ; diff --git a/library/list-namespaces.factor b/library/list-namespaces.factor deleted file mode 100644 index 0bab6cbfaa..0000000000 --- a/library/list-namespaces.factor +++ /dev/null @@ -1,65 +0,0 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2003, 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -IN: lists -USE: kernel -USE: namespaces - -: cons@ ( x var -- ) - #! Prepend x to the list stored in var. - [ cons ] change ; - -: unique@ ( elem var -- ) - #! Prepend an element to the proper list stored in a - #! variable if it is not already contained in the list. - [ unique ] change ; - -SYMBOL: list-buffer - -: make-rlist ( quot -- list ) - #! Call a quotation. The quotation can call , to prepend - #! objects to the list that is returned when the quotation - #! is done. - [ list-buffer off call list-buffer get ] with-scope ; - inline - -: make-list ( quot -- list ) - #! Return a list whose entries are in the same order that , - #! was called. - make-rlist reverse ; inline - -: , ( obj -- ) - #! Append an object to the currently constructing list. - list-buffer cons@ ; - -: unique, ( obj -- ) - #! Append an object to the currently constructing list, only - #! if the object does not already occur in the list. - list-buffer unique@ ; - -: append, ( list -- ) - [ , ] each ; diff --git a/library/namespaces.factor b/library/namespaces.factor index d5ab7f413c..e1632b9c47 100644 --- a/library/namespaces.factor +++ b/library/namespaces.factor @@ -31,6 +31,7 @@ USE: kernel USE: kernel-internals USE: lists USE: vectors +USE: math ! Other languages have classes, objects, variables, etc. ! Factor has similar concepts. @@ -126,3 +127,40 @@ USE: vectors : on ( var -- ) t put ; : off ( var -- ) f put ; +: inc ( var -- ) [ 1 + ] change ; +: dec ( var -- ) [ 1 - ] change ; + +: cons@ ( x var -- ) + #! Prepend x to the list stored in var. + [ cons ] change ; + +: unique@ ( elem var -- ) + #! Prepend an element to the proper list stored in a + #! variable if it is not already contained in the list. + [ unique ] change ; + +SYMBOL: list-buffer + +: make-rlist ( quot -- list ) + #! Call a quotation. The quotation can call , to prepend + #! objects to the list that is returned when the quotation + #! is done. + [ list-buffer off call list-buffer get ] with-scope ; + inline + +: make-list ( quot -- list ) + #! Return a list whose entries are in the same order that , + #! was called. + make-rlist reverse ; inline + +: , ( obj -- ) + #! Append an object to the currently constructing list. + list-buffer cons@ ; + +: unique, ( obj -- ) + #! Append an object to the currently constructing list, only + #! if the object does not already occur in the list. + list-buffer unique@ ; + +: append, ( list -- ) + [ , ] each ; diff --git a/library/primitives.factor b/library/primitives.factor index 92b827dd0b..9847467c24 100644 --- a/library/primitives.factor +++ b/library/primitives.factor @@ -150,7 +150,7 @@ USE: words [ getenv [ [ fixnum ] [ object ] ] ] [ setenv [ [ object fixnum ] [ ] ] ] [ open-file [ [ string object object ] [ port ] ] ] - [ stat [ [ string ] [ cons ] ] ] + [ stat [ [ string ] [ general-list ] ] ] [ (directory) [ [ string ] [ general-list ] ] ] [ garbage-collection [ [ ] [ ] ] ] [ save-image [ [ string ] [ ] ] ] diff --git a/library/syntax/see.factor b/library/syntax/see.factor index 32f288980c..b8d20c1ccb 100644 --- a/library/syntax/see.factor +++ b/library/syntax/see.factor @@ -30,6 +30,7 @@ USE: generic USE: kernel USE: lists USE: math +USE: namespaces USE: stdio USE: strings USE: presentation diff --git a/library/test/inference.factor b/library/test/inference.factor index b20194370a..31ab36ece6 100644 --- a/library/test/inference.factor +++ b/library/test/inference.factor @@ -11,18 +11,6 @@ USE: kernel USE: math-internals USE: generic -[ 0 ] -[ { 1 2 3 } { 4 5 6 } vector-zip 0 swap raise# ] -unit-test - -[ 2 ] -[ { 1 2 3 } { 1 2 6 } vector-zip 0 swap raise# ] -unit-test - -[ { 4 5 6 } ] -[ { 1 2 3 } dup [ 4 5 6 ] unify-entry-effect ] -unit-test - ! [ [ [ object object ] f ] ] ! [ [ [ object ] [ object object ] ] [ [ object ] f ] decompose ] ! unit-test @@ -143,8 +131,8 @@ DEFER: foe [ [ 2 | 1 ] ] [ [ foe ] infer old-effect ] unit-test ! This form should not have a stack effect -: bad-bin 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] ifte ; -[ [ bad-bin ] infer old-effect ] unit-test-fails +! : bad-bin 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] ifte ; +! [ [ bad-bin ] infer old-effect ] unit-test-fails : nested-when ( -- ) t [ From 7e8a87f213f4c407dd35fd149734f550ab6b9646 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 14 Jan 2005 00:49:47 +0000 Subject: [PATCH 019/122] [[ car cdr ]] syntax replaces [ car | cdr ] --- examples/irc.factor | 4 +- examples/more-random.factor | 8 +- factor/Cons.java | 36 +- factor/DefaultVocabularyLookup.java | 8 +- factor/parser/{Bar.java => BeginCons.java} | 18 +- factor/parser/EndCons.java | 51 +++ library/assoc.factor | 2 +- library/bootstrap/image.factor | 6 +- library/bootstrap/primitives.factor | 342 +++++++-------- library/compiler/generator.factor | 2 +- library/compiler/optimizer.factor | 12 +- library/compiler/simplifier.factor | 8 +- library/cons.factor | 10 +- library/generic/union.factor | 4 +- library/hashtables.factor | 2 +- library/httpd/html.factor | 10 +- library/httpd/http-common.factor | 6 +- library/httpd/httpd.factor | 6 +- library/httpd/responder.factor | 2 +- library/inference/branches.factor | 10 +- library/inference/inference.factor | 8 +- library/inference/words.factor | 4 +- library/io/files.factor | 34 +- library/io/presentation.factor | 10 +- library/io/vocabulary-style.factor | 58 +-- library/sdl/sdl-keysym.factor | 488 ++++++++++----------- library/syntax/parse-syntax.factor | 42 +- library/syntax/parser.factor | 30 +- library/syntax/prettyprint.factor | 29 +- library/syntax/see.factor | 6 +- library/syntax/unparser.factor | 14 +- library/test/alien.factor | 4 +- library/test/benchmark/sort.factor | 1 + library/test/benchmark/strings.factor | 1 + library/test/compiler/optimizer.factor | 18 +- library/test/compiler/simplifier.factor | 24 +- library/test/dataflow.factor | 10 +- library/test/generic.factor | 6 +- library/test/hashtables.factor | 12 +- library/test/httpd/html.factor | 6 +- library/test/httpd/httpd.factor | 12 +- library/test/inference.factor | 126 +++--- library/test/interpreter.factor | 2 +- library/test/lists/assoc.factor | 20 +- library/test/lists/cons.factor | 20 +- library/test/lists/lists.factor | 10 +- library/test/lists/namespaces.factor | 4 +- library/test/parser.factor | 6 +- library/test/styles.factor | 2 +- library/test/vectors.factor | 2 +- library/ui/console.factor | 14 +- library/win32/win32-errors.factor | 2 +- 52 files changed, 807 insertions(+), 765 deletions(-) rename factor/parser/{Bar.java => BeginCons.java} (79%) create mode 100644 factor/parser/EndCons.java diff --git a/examples/irc.factor b/examples/irc.factor index 90a98dd35f..5ce632dd9e 100644 --- a/examples/irc.factor +++ b/examples/irc.factor @@ -32,13 +32,13 @@ SYMBOL: nickname : write-highlighted ( line -- ) dup nickname get index-of -1 = - f [ [ "ansi-fg" | "3" ] ] ? write-attr ; + f [ [[ "ansi-fg" "3" ]] ] ? write-attr ; : extract-nick ( line -- nick ) "!" split1 drop ; : write-nick ( line -- ) - "!" split1 drop [ [ "bold" | t ] ] write-attr ; + "!" split1 drop [ [[ "bold" t ]] ] write-attr ; GENERIC: irc-display PREDICATE: string privmsg "PRIVMSG" index-of -1 > ; diff --git a/examples/more-random.factor b/examples/more-random.factor index d9db9d74d0..d2ba371b23 100644 --- a/examples/more-random.factor +++ b/examples/more-random.factor @@ -72,10 +72,10 @@ USE: namespaces unit-test [ - [ 10 | t ] - [ 20 | f ] - [ 30 | "monkey" ] - [ 24 | 1/2 ] + [[ 10 t ]] + [[ 20 f ]] + [[ 30 "monkey" ]] + [[ 24 1/2 ]] [ 13 | { "Hello" "Banana" } ] ] "random-pairs" set diff --git a/factor/Cons.java b/factor/Cons.java index 76412eafce..44cd84799d 100644 --- a/factor/Cons.java +++ b/factor/Cons.java @@ -50,6 +50,17 @@ public class Cons implements FactorExternalizable return (Cons)cdr; } //}}} + //{{{ isList() method + public static boolean isList(Object list) + { + if(list == null) + return true; + else if(list instanceof Cons) + return isList(((Cons)list).cdr); + else + return false; + } //}}} + //{{{ contains() method public static boolean contains(Cons list, Object obj) { @@ -98,20 +109,8 @@ public class Cons implements FactorExternalizable while(iter != null) { buf.append(FactorReader.unparseObject(iter.car)); - if(iter.cdr instanceof Cons) - { - buf.append(' '); - iter = (Cons)iter.cdr; - continue; - } - else if(iter.cdr == null) - break; - else - { - buf.append(" | "); - buf.append(FactorReader.unparseObject(iter.cdr)); - iter = null; - } + buf.append(' '); + iter = iter.next(); } return buf.toString(); @@ -123,7 +122,14 @@ public class Cons implements FactorExternalizable */ public String toString() { - return "[ " + elementsToString() + " ]"; + if(isList(this)) + return "[ " + elementsToString() + " ]"; + else + { + return "[[ " + FactorReader.unparseObject(car) + + " " + FactorReader.unparseObject(cdr) + + " ]]"; + } } //}}} //{{{ toArray() method diff --git a/factor/DefaultVocabularyLookup.java b/factor/DefaultVocabularyLookup.java index 256336c3b6..9c2ced02e9 100644 --- a/factor/DefaultVocabularyLookup.java +++ b/factor/DefaultVocabularyLookup.java @@ -75,8 +75,12 @@ public class DefaultVocabularyLookup implements VocabularyLookup bra.parsing = new Bra(bra); FactorWord ket = define("syntax","]"); ket.parsing = new Ket(bra,ket); - FactorWord bar = define("syntax","|"); - bar.parsing = new Bar(bar); + + /* conses */ + FactorWord beginCons = define("syntax","[["); + beginCons.parsing = new BeginCons(beginCons); + FactorWord endCons = define("syntax","]]"); + endCons.parsing = new EndCons(beginCons,endCons); /* vectors */ FactorWord beginVector = define("syntax","{"); diff --git a/factor/parser/Bar.java b/factor/parser/BeginCons.java similarity index 79% rename from factor/parser/Bar.java rename to factor/parser/BeginCons.java index a1ff0120bf..dd9113f531 100644 --- a/factor/parser/Bar.java +++ b/factor/parser/BeginCons.java @@ -3,7 +3,7 @@ /* * $Id$ * - * Copyright (C) 2004 Slava Pestov. + * Copyright (C) 2005 Slava Pestov. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are met: @@ -31,23 +31,15 @@ package factor.parser; import factor.*; -public class Bar extends FactorParsingDefinition +public class BeginCons extends FactorParsingDefinition { - //{{{ Bar constructor - /** - * A new definition. - */ - public Bar(FactorWord word) + public BeginCons(FactorWord word) { super(word); - } //}}} + } public void eval(FactorReader reader) - throws Exception { - FactorReader.ParseState state = reader.getCurrentState(); - if(state.start != reader.intern("[",false)) - reader.error("| only allowed inside [ ... ]"); - reader.bar(); + reader.pushState(word,null); } } diff --git a/factor/parser/EndCons.java b/factor/parser/EndCons.java new file mode 100644 index 0000000000..93a439bd44 --- /dev/null +++ b/factor/parser/EndCons.java @@ -0,0 +1,51 @@ +/* :folding=explicit:collapseFolds=1: */ + +/* + * $Id$ + * + * Copyright (C) 2005 Slava Pestov. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * 1. Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND + * FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; + * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, + * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR + * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF + * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + */ + +package factor.parser; + +import factor.*; + +public class EndCons extends FactorParsingDefinition +{ + public FactorWord start; + + public EndCons(FactorWord start, FactorWord end) + { + super(end); + this.start = start; + } + + public void eval(FactorReader reader) throws FactorParseException + { + Cons list = reader.popState(start,word).first; + if(Cons.length(list) != 2) + reader.getScanner().error("Exactly two objects must be between [[ and ]]"); + reader.append(new Cons(list.car,list.next().car)); + } +} diff --git a/library/assoc.factor b/library/assoc.factor index 62bf6723b6..ed5001c8b3 100644 --- a/library/assoc.factor +++ b/library/assoc.factor @@ -36,7 +36,7 @@ USE: kernel #! Push if the list appears to be an alist. dup list? [ [ cons? ] all? ] [ drop f ] ifte ; -: assoc* ( key alist -- [ key | value ] ) +: assoc* ( key alist -- [[ key value ]] ) #! Looks up the key in an alist. Push the key/value pair. #! Most of the time you want to use assoc not assoc*. dup [ diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index 063d21bbfb..4b3435f41d 100644 --- a/library/bootstrap/image.factor +++ b/library/bootstrap/image.factor @@ -159,9 +159,9 @@ M: bignum ' ( bignum -- tagged ) object-tag here-as >r bignum-type >header emit [ - [ 0 | [ 1 0 ] ] - [ -1 | [ 2 1 1 ] ] - [ 1 | [ 2 0 1 ] ] + [[ 0 [ 1 0 ] ]] + [[ -1 [ 2 1 1 ] ]] + [[ 1 [ 2 0 1 ] ]] ] assoc [ emit ] each align-here r> ; ( Special objects ) diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor index 05020fef34..e49e5750b5 100644 --- a/library/bootstrap/primitives.factor +++ b/library/bootstrap/primitives.factor @@ -54,177 +54,177 @@ vocabularies get [ classes set 2 [ - [ "words" | "execute" ] - [ "kernel" | "call" ] - [ "kernel" | "ifte" ] - [ "lists" | "cons" ] - [ "vectors" | "" ] - [ "vectors" | "vector-nth" ] - [ "vectors" | "set-vector-nth" ] - [ "strings" | "str-nth" ] - [ "strings" | "str-compare" ] - [ "strings" | "str=" ] - [ "strings" | "index-of*" ] - [ "strings" | "substring" ] - [ "strings" | "str-reverse" ] - [ "strings" | "" ] - [ "strings" | "sbuf-length" ] - [ "strings" | "set-sbuf-length" ] - [ "strings" | "sbuf-nth" ] - [ "strings" | "set-sbuf-nth" ] - [ "strings" | "sbuf-append" ] - [ "strings" | "sbuf>str" ] - [ "strings" | "sbuf-reverse" ] - [ "strings" | "sbuf-clone" ] - [ "strings" | "sbuf=" ] - [ "strings" | "sbuf-hashcode" ] - [ "math-internals" | "arithmetic-type" ] - [ "math" | ">fixnum" ] - [ "math" | ">bignum" ] - [ "math" | ">float" ] - [ "math-internals" | "(fraction>)" ] - [ "parser" | "str>float" ] - [ "unparser" | "(unparse-float)" ] - [ "math-internals" | "(rect>)" ] - [ "math-internals" | "fixnum=" ] - [ "math-internals" | "fixnum+" ] - [ "math-internals" | "fixnum-" ] - [ "math-internals" | "fixnum*" ] - [ "math-internals" | "fixnum/i" ] - [ "math-internals" | "fixnum/f" ] - [ "math-internals" | "fixnum-mod" ] - [ "math-internals" | "fixnum/mod" ] - [ "math-internals" | "fixnum-bitand" ] - [ "math-internals" | "fixnum-bitor" ] - [ "math-internals" | "fixnum-bitxor" ] - [ "math-internals" | "fixnum-bitnot" ] - [ "math-internals" | "fixnum-shift" ] - [ "math-internals" | "fixnum<" ] - [ "math-internals" | "fixnum<=" ] - [ "math-internals" | "fixnum>" ] - [ "math-internals" | "fixnum>=" ] - [ "math-internals" | "bignum=" ] - [ "math-internals" | "bignum+" ] - [ "math-internals" | "bignum-" ] - [ "math-internals" | "bignum*" ] - [ "math-internals" | "bignum/i" ] - [ "math-internals" | "bignum/f" ] - [ "math-internals" | "bignum-mod" ] - [ "math-internals" | "bignum/mod" ] - [ "math-internals" | "bignum-bitand" ] - [ "math-internals" | "bignum-bitor" ] - [ "math-internals" | "bignum-bitxor" ] - [ "math-internals" | "bignum-bitnot" ] - [ "math-internals" | "bignum-shift" ] - [ "math-internals" | "bignum<" ] - [ "math-internals" | "bignum<=" ] - [ "math-internals" | "bignum>" ] - [ "math-internals" | "bignum>=" ] - [ "math-internals" | "float=" ] - [ "math-internals" | "float+" ] - [ "math-internals" | "float-" ] - [ "math-internals" | "float*" ] - [ "math-internals" | "float/f" ] - [ "math-internals" | "float<" ] - [ "math-internals" | "float<=" ] - [ "math-internals" | "float>" ] - [ "math-internals" | "float>=" ] - [ "math-internals" | "facos" ] - [ "math-internals" | "fasin" ] - [ "math-internals" | "fatan" ] - [ "math-internals" | "fatan2" ] - [ "math-internals" | "fcos" ] - [ "math-internals" | "fexp" ] - [ "math-internals" | "fcosh" ] - [ "math-internals" | "flog" ] - [ "math-internals" | "fpow" ] - [ "math-internals" | "fsin" ] - [ "math-internals" | "fsinh" ] - [ "math-internals" | "fsqrt" ] - [ "words" | "" ] - [ "words" | "update-xt" ] - [ "profiler" | "call-profiling" ] - [ "profiler" | "allot-profiling" ] - [ "words" | "compiled?" ] - [ "kernel" | "drop" ] - [ "kernel" | "dup" ] - [ "kernel" | "swap" ] - [ "kernel" | "over" ] - [ "kernel" | "pick" ] - [ "kernel" | ">r" ] - [ "kernel" | "r>" ] - [ "kernel" | "eq?" ] - [ "kernel-internals" | "getenv" ] - [ "kernel-internals" | "setenv" ] - [ "io-internals" | "open-file" ] - [ "files" | "stat" ] - [ "files" | "(directory)" ] - [ "kernel" | "garbage-collection" ] - [ "kernel" | "gc-time" ] - [ "kernel" | "save-image" ] - [ "kernel" | "datastack" ] - [ "kernel" | "callstack" ] - [ "kernel" | "set-datastack" ] - [ "kernel" | "set-callstack" ] - [ "kernel" | "exit*" ] - [ "io-internals" | "client-socket" ] - [ "io-internals" | "server-socket" ] - [ "io-internals" | "close-port" ] - [ "io-internals" | "add-accept-io-task" ] - [ "io-internals" | "accept-fd" ] - [ "io-internals" | "can-read-line?" ] - [ "io-internals" | "add-read-line-io-task" ] - [ "io-internals" | "read-line-fd-8" ] - [ "io-internals" | "can-read-count?" ] - [ "io-internals" | "add-read-count-io-task" ] - [ "io-internals" | "read-count-fd-8" ] - [ "io-internals" | "can-write?" ] - [ "io-internals" | "add-write-io-task" ] - [ "io-internals" | "write-fd-8" ] - [ "io-internals" | "add-copy-io-task" ] - [ "io-internals" | "pending-io-error" ] - [ "io-internals" | "next-io-task" ] - [ "kernel" | "room" ] - [ "kernel" | "os-env" ] - [ "kernel" | "millis" ] - [ "random" | "init-random" ] - [ "random" | "(random-int)" ] - [ "kernel" | "type" ] - [ "files" | "cwd" ] - [ "files" | "cd" ] - [ "assembler" | "compiled-offset" ] - [ "assembler" | "set-compiled-offset" ] - [ "assembler" | "literal-top" ] - [ "assembler" | "set-literal-top" ] - [ "kernel" | "address" ] - [ "alien" | "dlopen" ] - [ "alien" | "dlsym" ] - [ "alien" | "dlclose" ] - [ "alien" | "" ] - [ "alien" | "" ] - [ "alien" | "alien-cell" ] - [ "alien" | "set-alien-cell" ] - [ "alien" | "alien-4" ] - [ "alien" | "set-alien-4" ] - [ "alien" | "alien-2" ] - [ "alien" | "set-alien-2" ] - [ "alien" | "alien-1" ] - [ "alien" | "set-alien-1" ] - [ "kernel" | "heap-stats" ] - [ "errors" | "throw" ] - [ "kernel-internals" | "string>memory" ] - [ "kernel-internals" | "memory>string" ] - [ "alien" | "local-alien?" ] - [ "alien" | "alien-address" ] - [ "lists" | ">cons" ] - [ "vectors" | ">vector" ] - [ "strings" | ">string" ] - [ "words" | ">word" ] - [ "kernel-internals" | "slot" ] - [ "kernel-internals" | "set-slot" ] - [ "kernel-internals" | "integer-slot" ] - [ "kernel-internals" | "set-integer-slot" ] - [ "kernel-internals" | "grow-array" ] + [[ "words" "execute" ]] + [[ "kernel" "call" ]] + [[ "kernel" "ifte" ]] + [[ "lists" "cons" ]] + [[ "vectors" "" ]] + [[ "vectors" "vector-nth" ]] + [[ "vectors" "set-vector-nth" ]] + [[ "strings" "str-nth" ]] + [[ "strings" "str-compare" ]] + [[ "strings" "str=" ]] + [[ "strings" "index-of*" ]] + [[ "strings" "substring" ]] + [[ "strings" "str-reverse" ]] + [[ "strings" "" ]] + [[ "strings" "sbuf-length" ]] + [[ "strings" "set-sbuf-length" ]] + [[ "strings" "sbuf-nth" ]] + [[ "strings" "set-sbuf-nth" ]] + [[ "strings" "sbuf-append" ]] + [[ "strings" "sbuf>str" ]] + [[ "strings" "sbuf-reverse" ]] + [[ "strings" "sbuf-clone" ]] + [[ "strings" "sbuf=" ]] + [[ "strings" "sbuf-hashcode" ]] + [[ "math-internals" "arithmetic-type" ]] + [[ "math" ">fixnum" ]] + [[ "math" ">bignum" ]] + [[ "math" ">float" ]] + [[ "math-internals" "(fraction>)" ]] + [[ "parser" "str>float" ]] + [[ "unparser" "(unparse-float)" ]] + [[ "math-internals" "(rect>)" ]] + [[ "math-internals" "fixnum=" ]] + [[ "math-internals" "fixnum+" ]] + [[ "math-internals" "fixnum-" ]] + [[ "math-internals" "fixnum*" ]] + [[ "math-internals" "fixnum/i" ]] + [[ "math-internals" "fixnum/f" ]] + [[ "math-internals" "fixnum-mod" ]] + [[ "math-internals" "fixnum/mod" ]] + [[ "math-internals" "fixnum-bitand" ]] + [[ "math-internals" "fixnum-bitor" ]] + [[ "math-internals" "fixnum-bitxor" ]] + [[ "math-internals" "fixnum-bitnot" ]] + [[ "math-internals" "fixnum-shift" ]] + [[ "math-internals" "fixnum<" ]] + [[ "math-internals" "fixnum<=" ]] + [[ "math-internals" "fixnum>" ]] + [[ "math-internals" "fixnum>=" ]] + [[ "math-internals" "bignum=" ]] + [[ "math-internals" "bignum+" ]] + [[ "math-internals" "bignum-" ]] + [[ "math-internals" "bignum*" ]] + [[ "math-internals" "bignum/i" ]] + [[ "math-internals" "bignum/f" ]] + [[ "math-internals" "bignum-mod" ]] + [[ "math-internals" "bignum/mod" ]] + [[ "math-internals" "bignum-bitand" ]] + [[ "math-internals" "bignum-bitor" ]] + [[ "math-internals" "bignum-bitxor" ]] + [[ "math-internals" "bignum-bitnot" ]] + [[ "math-internals" "bignum-shift" ]] + [[ "math-internals" "bignum<" ]] + [[ "math-internals" "bignum<=" ]] + [[ "math-internals" "bignum>" ]] + [[ "math-internals" "bignum>=" ]] + [[ "math-internals" "float=" ]] + [[ "math-internals" "float+" ]] + [[ "math-internals" "float-" ]] + [[ "math-internals" "float*" ]] + [[ "math-internals" "float/f" ]] + [[ "math-internals" "float<" ]] + [[ "math-internals" "float<=" ]] + [[ "math-internals" "float>" ]] + [[ "math-internals" "float>=" ]] + [[ "math-internals" "facos" ]] + [[ "math-internals" "fasin" ]] + [[ "math-internals" "fatan" ]] + [[ "math-internals" "fatan2" ]] + [[ "math-internals" "fcos" ]] + [[ "math-internals" "fexp" ]] + [[ "math-internals" "fcosh" ]] + [[ "math-internals" "flog" ]] + [[ "math-internals" "fpow" ]] + [[ "math-internals" "fsin" ]] + [[ "math-internals" "fsinh" ]] + [[ "math-internals" "fsqrt" ]] + [[ "words" "" ]] + [[ "words" "update-xt" ]] + [[ "profiler" "call-profiling" ]] + [[ "profiler" "allot-profiling" ]] + [[ "words" "compiled?" ]] + [[ "kernel" "drop" ]] + [[ "kernel" "dup" ]] + [[ "kernel" "swap" ]] + [[ "kernel" "over" ]] + [[ "kernel" "pick" ]] + [[ "kernel" ">r" ]] + [[ "kernel" "r>" ]] + [[ "kernel" "eq?" ]] + [[ "kernel-internals" "getenv" ]] + [[ "kernel-internals" "setenv" ]] + [[ "io-internals" "open-file" ]] + [[ "files" "stat" ]] + [[ "files" "(directory)" ]] + [[ "kernel" "garbage-collection" ]] + [[ "kernel" "gc-time" ]] + [[ "kernel" "save-image" ]] + [[ "kernel" "datastack" ]] + [[ "kernel" "callstack" ]] + [[ "kernel" "set-datastack" ]] + [[ "kernel" "set-callstack" ]] + [[ "kernel" "exit*" ]] + [[ "io-internals" "client-socket" ]] + [[ "io-internals" "server-socket" ]] + [[ "io-internals" "close-port" ]] + [[ "io-internals" "add-accept-io-task" ]] + [[ "io-internals" "accept-fd" ]] + [[ "io-internals" "can-read-line?" ]] + [[ "io-internals" "add-read-line-io-task" ]] + [[ "io-internals" "read-line-fd-8" ]] + [[ "io-internals" "can-read-count?" ]] + [[ "io-internals" "add-read-count-io-task" ]] + [[ "io-internals" "read-count-fd-8" ]] + [[ "io-internals" "can-write?" ]] + [[ "io-internals" "add-write-io-task" ]] + [[ "io-internals" "write-fd-8" ]] + [[ "io-internals" "add-copy-io-task" ]] + [[ "io-internals" "pending-io-error" ]] + [[ "io-internals" "next-io-task" ]] + [[ "kernel" "room" ]] + [[ "kernel" "os-env" ]] + [[ "kernel" "millis" ]] + [[ "random" "init-random" ]] + [[ "random" "(random-int)" ]] + [[ "kernel" "type" ]] + [[ "files" "cwd" ]] + [[ "files" "cd" ]] + [[ "assembler" "compiled-offset" ]] + [[ "assembler" "set-compiled-offset" ]] + [[ "assembler" "literal-top" ]] + [[ "assembler" "set-literal-top" ]] + [[ "kernel" "address" ]] + [[ "alien" "dlopen" ]] + [[ "alien" "dlsym" ]] + [[ "alien" "dlclose" ]] + [[ "alien" "" ]] + [[ "alien" "" ]] + [[ "alien" "alien-cell" ]] + [[ "alien" "set-alien-cell" ]] + [[ "alien" "alien-4" ]] + [[ "alien" "set-alien-4" ]] + [[ "alien" "alien-2" ]] + [[ "alien" "set-alien-2" ]] + [[ "alien" "alien-1" ]] + [[ "alien" "set-alien-1" ]] + [[ "kernel" "heap-stats" ]] + [[ "errors" "throw" ]] + [[ "kernel-internals" "string>memory" ]] + [[ "kernel-internals" "memory>string" ]] + [[ "alien" "local-alien?" ]] + [[ "alien" "alien-address" ]] + [[ "lists" ">cons" ]] + [[ "vectors" ">vector" ]] + [[ "strings" ">string" ]] + [[ "words" ">word" ]] + [[ "kernel-internals" "slot" ]] + [[ "kernel-internals" "set-slot" ]] + [[ "kernel-internals" "integer-slot" ]] + [[ "kernel-internals" "set-integer-slot" ]] + [[ "kernel-internals" "grow-array" ]] ] [ unswons create swap 1 + [ f define ] keep ] each drop diff --git a/library/compiler/generator.factor b/library/compiler/generator.factor index 60b41c8948..741cc386b0 100644 --- a/library/compiler/generator.factor +++ b/library/compiler/generator.factor @@ -61,7 +61,7 @@ SYMBOL: relocation-table #! Relocate address just compiled. 4 rel, relocating 0 rel, ; -: generate-node ( [ op | params ] -- ) +: generate-node ( [[ op params ]] -- ) #! Generate machine code for a node. unswons dup "generator" word-property [ call diff --git a/library/compiler/optimizer.factor b/library/compiler/optimizer.factor index 349c9d76cb..811299869a 100644 --- a/library/compiler/optimizer.factor +++ b/library/compiler/optimizer.factor @@ -202,18 +202,18 @@ USE: prettyprint \ over [ 2drop t ] "can-kill" set-word-property \ over [ [ - [ [ f f ] | over ] - [ [ f t ] | dup ] + [[ [ f f ] over ]] + [[ [ f t ] dup ]] ] reduce-stack-op ] "kill-node" set-word-property \ pick [ 2drop t ] "can-kill" set-word-property \ pick [ [ - [ [ f f f ] | pick ] - [ [ f f t ] | over ] - [ [ f t f ] | over ] - [ [ f t t ] | dup ] + [[ [ f f f ] pick ]] + [[ [ f f t ] over ]] + [[ [ f t f ] over ]] + [[ [ f t t ] dup ]] ] reduce-stack-op ] "kill-node" set-word-property diff --git a/library/compiler/simplifier.factor b/library/compiler/simplifier.factor index 0db9947baf..66adc5ba08 100644 --- a/library/compiler/simplifier.factor +++ b/library/compiler/simplifier.factor @@ -101,8 +101,8 @@ PREDICATE: cons return-follows #return swap follows? ; M: return-follows simplify-call ( node rest -- rest ? ) >r unswons [ - [ #call | #jump ] - [ #call-label | #jump-label ] + [[ #call #jump ]] + [[ #call-label #jump-label ]] ] assoc swons , r> t ; #call [ simplify-call ] "simplify" set-word-property @@ -119,8 +119,8 @@ PREDICATE: cons push-next ( list -- ? ) M: push-next simplify-drop ( node rest -- rest ? ) nip uncons >r unswons [ - [ #push-immediate | #replace-immediate ] - [ #push-indirect | #replace-indirect ] + [[ #push-immediate #replace-immediate ]] + [[ #push-indirect #replace-indirect ]] ] assoc swons , r> t ; \ drop [ simplify-drop ] "simplify" set-word-property diff --git a/library/cons.factor b/library/cons.factor index b75c56abd1..21c5abd1d3 100644 --- a/library/cons.factor +++ b/library/cons.factor @@ -36,15 +36,15 @@ USE: kernel-internals BUILTIN: cons 2 -: car ( [ car | cdr ] -- car ) >cons 0 slot ; inline -: cdr ( [ car | cdr ] -- cdr ) >cons 1 slot ; inline +: car ( [[ car cdr ]] -- car ) >cons 0 slot ; inline +: cdr ( [[ car cdr ]] -- cdr ) >cons 1 slot ; inline -: swons ( cdr car -- [ car | cdr ] ) +: swons ( cdr car -- [[ car cdr ]] ) #! Push a new cons cell. If the cdr is f or a proper list, #! has the effect of prepending the car to the cdr. swap cons ; inline -: uncons ( [ car | cdr ] -- car cdr ) +: uncons ( [[ car cdr ]] -- car cdr ) #! Push both the head and tail of a list. dup car swap cdr ; inline @@ -52,7 +52,7 @@ BUILTIN: cons 2 #! Construct a proper list of one element. f cons ; inline -: unswons ( [ car | cdr ] -- cdr car ) +: unswons ( [[ car cdr ]] -- cdr car ) #! Push both the head and tail of a list. dup cdr swap car ; inline diff --git a/library/generic/union.factor b/library/generic/union.factor index 1bcf11cfa8..bca22d3859 100644 --- a/library/generic/union.factor +++ b/library/generic/union.factor @@ -72,8 +72,8 @@ union [ 2drop t ] "class<" set-word-property [ [ [ - [ f | POSTPONE: f ] - [ t | POSTPONE: t ] + [[ f POSTPONE: f ]] + [[ t POSTPONE: t ]] ] assoc dup ] keep ? ] map diff --git a/library/hashtables.factor b/library/hashtables.factor index 277459f16e..e910815fc7 100644 --- a/library/hashtables.factor +++ b/library/hashtables.factor @@ -50,7 +50,7 @@ PREDICATE: vector hashtable ( obj -- ? ) #! Compute the index of the bucket for a key. >r hashcode r> vector-length rem ; inline -: hash* ( key table -- [ key | value ] ) +: hash* ( key table -- [[ key value ]] ) #! Look up a value in the hashtable. First the bucket is #! determined using the hash function, then the association #! list therein is searched linearly. diff --git a/library/httpd/html.factor b/library/httpd/html.factor index 00f3f3fdad..3d9fd7cd95 100644 --- a/library/httpd/html.factor +++ b/library/httpd/html.factor @@ -39,11 +39,11 @@ USE: generic : html-entities ( -- alist ) [ - [ CHAR: < | "<" ] - [ CHAR: > | ">" ] - [ CHAR: & | "&" ] - [ CHAR: ' | "'" ] - [ CHAR: " | """ ] + [[ CHAR: < "<" ]] + [[ CHAR: > ">" ]] + [[ CHAR: & "&" ]] + [[ CHAR: ' "'" ]] + [[ CHAR: " """ ]] ] ; : char>entity ( ch -- str ) diff --git a/library/httpd/http-common.factor b/library/httpd/http-common.factor index afb4b2faf1..ebeef31687 100644 --- a/library/httpd/http-common.factor +++ b/library/httpd/http-common.factor @@ -50,7 +50,7 @@ USE: url-encoding : error-head ( error -- ) dup log-error - [ [ "Content-Type" | "text/html" ] ] over response ; + [ [[ "Content-Type" "text/html" ]] ] over response ; : httpd-error ( error -- ) #! This must be run from handle-request @@ -65,11 +65,11 @@ USE: url-encoding ] with-scope ; : serving-html ( -- ) - [ [ "Content-Type" | "text/html" ] ] + [ [[ "Content-Type" "text/html" ]] ] "200 Document follows" response terpri ; : serving-text ( -- ) - [ [ "Content-Type" | "text/plain" ] ] + [ [[ "Content-Type" "text/plain" ]] ] "200 Document follows" response terpri ; : redirect ( to -- ) diff --git a/library/httpd/httpd.factor b/library/httpd/httpd.factor index b0822ac90d..a55fcdff08 100644 --- a/library/httpd/httpd.factor +++ b/library/httpd/httpd.factor @@ -56,9 +56,9 @@ USE: url-encoding : request-method ( cmd -- method ) [ - [ "GET" | "get" ] - [ "POST" | "post" ] - [ "HEAD" | "head" ] + [[ "GET" "get" ]] + [[ "POST" "post" ]] + [[ "HEAD" "head" ]] ] assoc [ "bad" ] unless* ; : (handle-request) ( arg cmd -- url method ) diff --git a/library/httpd/responder.factor b/library/httpd/responder.factor index b374dbabba..c5ca5710c3 100644 --- a/library/httpd/responder.factor +++ b/library/httpd/responder.factor @@ -46,7 +46,7 @@ USE: strings ! - raw-query -- raw query string ! - query -- an alist of query parameters, eg ! foo.bar?a=b&c=d becomes -! [ [ "a" | "b" ] [ "c" | "d" ] ] +! [ [[ "a" "b" ]] [[ "c" "d" ]] ] ! - header -- an alist of headers from the user's client ! - response -- an alist of the POST request response diff --git a/library/inference/branches.factor b/library/inference/branches.factor index a01924c3dd..a79423b5be 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -76,12 +76,12 @@ USE: prettyprint unify-lengths vector-transpose [ unify-results ] vector-map ; : balanced? ( list -- ? ) - #! Check if a list of [ instack | outstack ] pairs is + #! Check if a list of [[ instack outstack ]] pairs is #! balanced. [ uncons vector-length swap vector-length - ] map all=? ; : unify-effect ( list -- in out ) - #! Unify a list of [ instack | outstack ] pairs. + #! Unify a list of [[ instack outstack ]] pairs. dup balanced? [ unzip unify-stacks >r unify-stacks r> ] [ @@ -136,7 +136,7 @@ SYMBOL: cloned meta-d off meta-r off d-in off ] when ; -: propagate-type ( [ value | class ] -- ) +: propagate-type ( [[ value class ]] -- ) #! Type propagation is chained. [ unswons 2dup set-value-class @@ -155,9 +155,9 @@ SYMBOL: cloned : (infer-branches) ( branchlist -- list ) #! The branchlist is a list of pairs: - #! [ value | typeprop ] + #! [[ value typeprop ]] #! value is either a literal or computed instance; typeprop - #! is a pair [ value | class ] indicating a type propagation + #! is a pair [[ value class ]] indicating a type propagation #! for the given branch. [ [ diff --git a/library/inference/inference.factor b/library/inference/inference.factor index 1df0f2199b..3d47425787 100644 --- a/library/inference/inference.factor +++ b/library/inference/inference.factor @@ -69,7 +69,7 @@ GENERIC: set-value-class ( class value -- ) ! A value has the following slots in addition to those relating ! to generics above: -! An association list mapping values to [ value | class ] pairs +! An association list mapping values to [[ value class ]] pairs SYMBOL: type-propagations TRAITS: computed @@ -145,11 +145,11 @@ M: literal set-value-class ( class value -- ) : (present-effect) ( vector -- list ) [ value-class ] vector-map vector>list ; -: present-effect ( [ d-in | meta-d ] -- [ in-types out-types ] ) +: present-effect ( [[ d-in meta-d ]] -- [ in-types out-types ] ) #! After inference is finished, collect information. uncons >r (present-effect) r> (present-effect) 2list ; -: effect ( -- [ d-in | meta-d ] ) +: effect ( -- [[ d-in meta-d ]] ) d-in get meta-d get cons ; : init-inference ( recursive-state -- ) @@ -193,7 +193,7 @@ DEFER: apply-word infer-quot #return values-node check-return ; -: infer ( quot -- [ in | out ] ) +: infer ( quot -- [[ in out ]] ) #! Stack effect of a quotation. [ (infer) effect present-effect ] with-scope ; diff --git a/library/inference/words.factor b/library/inference/words.factor index 9d77cd54b2..c06fc8d100 100644 --- a/library/inference/words.factor +++ b/library/inference/words.factor @@ -139,7 +139,7 @@ M: symbol (apply-word) ( word -- ) ] when ] when ; -: decompose ( x y -- [ d-in | meta-d ] ) +: decompose ( x y -- [[ d-in meta-d ]] ) #! Return a stack effect such that x*effect = y. uncons >r swap uncons >r over vector-length over vector-length - @@ -155,7 +155,7 @@ M: symbol (apply-word) ( word -- ) rethrow ] catch ; -: base-case ( word -- [ d-in | meta-d ] ) +: base-case ( word -- [[ d-in meta-d ]] ) [ [ copy-inference diff --git a/library/io/files.factor b/library/io/files.factor index 2519ad5392..5740658fa7 100644 --- a/library/io/files.factor +++ b/library/io/files.factor @@ -50,10 +50,10 @@ USE: unparser : file-actions ( -- list ) [ - [ "Push" | "" ] - [ "Run file" | "run-file" ] - [ "List directory" | "directory." ] - [ "Change directory" | "cd" ] + [[ "Push" "" ]] + [[ "Run file" "run-file" ]] + [[ "List directory" "directory." ]] + [[ "Change directory" "cd" ]] ] ; : set-mime-types ( assoc -- ) @@ -100,20 +100,20 @@ USE: unparser : dir. cwd directory. ; [ - [ "html" | "text/html" ] - [ "txt" | "text/plain" ] + [[ "html" "text/html" ]] + [[ "txt" "text/plain" ]] - [ "gif" | "image/gif" ] - [ "png" | "image/png" ] - [ "jpg" | "image/jpeg" ] - [ "jpeg" | "image/jpeg" ] + [[ "gif" "image/gif" ]] + [[ "png" "image/png" ]] + [[ "jpg" "image/jpeg" ]] + [[ "jpeg" "image/jpeg" ]] - [ "jar" | "application/octet-stream" ] - [ "zip" | "application/octet-stream" ] - [ "tgz" | "application/octet-stream" ] - [ "tar.gz" | "application/octet-stream" ] - [ "gz" | "application/octet-stream" ] + [[ "jar" "application/octet-stream" ]] + [[ "zip" "application/octet-stream" ]] + [[ "tgz" "application/octet-stream" ]] + [[ "tar.gz" "application/octet-stream" ]] + [[ "gz" "application/octet-stream" ]] - [ "factor" | "application/x-factor" ] - [ "factsp" | "application/x-factor-server-page" ] + [[ "factor" "application/x-factor" ]] + [[ "factsp" "application/x-factor-server-page" ]] ] set-mime-types diff --git a/library/io/presentation.factor b/library/io/presentation.factor index a55f5f876d..98783ac19a 100644 --- a/library/io/presentation.factor +++ b/library/io/presentation.factor @@ -50,15 +50,15 @@ USE: unparser "styles" set [ - [ "font" | "Monospaced" ] + [[ "font" "Monospaced" ]] ] "default" set-style [ - [ "bold" | t ] + [[ "bold" t ]] ] default-style append "prompt" set-style [ - [ "ansi-fg" | "0" ] - [ "ansi-bg" | "2" ] - [ "fg" | [ 255 0 0 ] ] + [[ "ansi-fg" "0" ]] + [[ "ansi-bg" "2" ]] + [[ "fg" [ 255 0 0 ] ]] ] default-style append "comments" set-style diff --git a/library/io/vocabulary-style.factor b/library/io/vocabulary-style.factor index 63a7c933e7..7226b87c3c 100644 --- a/library/io/vocabulary-style.factor +++ b/library/io/vocabulary-style.factor @@ -46,61 +46,61 @@ USE: words "vocabularies" set-style [ - [ "ansi-fg" | "1" ] - [ "fg" | [ 204 0 0 ] ] + [[ "ansi-fg" "1" ]] + [[ "fg" [ 204 0 0 ] ]] ] "arithmetic" set-vocab-style [ - [ "ansi-fg" | "1" ] - [ "fg" | [ 255 0 0 ] ] + [[ "ansi-fg" "1" ]] + [[ "fg" [ 255 0 0 ] ]] ] "errors" set-vocab-style [ - [ "ansi-fg" | "4" ] - [ "fg" | [ 153 102 255 ] ] + [[ "ansi-fg" "4" ]] + [[ "fg" [ 153 102 255 ] ]] ] "hashtables" set-vocab-style [ - [ "ansi-fg" | "2" ] - [ "fg" | [ 0 102 153 ] ] + [[ "ansi-fg" "2" ]] + [[ "fg" [ 0 102 153 ] ]] ] "lists" set-vocab-style [ - [ "ansi-fg" | "1" ] - [ "fg" | [ 204 0 0 ] ] + [[ "ansi-fg" "1" ]] + [[ "fg" [ 204 0 0 ] ]] ] "math" set-vocab-style [ - [ "ansi-fg" | "6" ] - [ "fg" | [ 0 153 255 ] ] + [[ "ansi-fg" "6" ]] + [[ "fg" [ 0 153 255 ] ]] ] "namespaces" set-vocab-style [ - [ "ansi-fg" | "2" ] - [ "fg" | [ 102 204 255 ] ] + [[ "ansi-fg" "2" ]] + [[ "fg" [ 102 204 255 ] ]] ] "parser" set-vocab-style [ - [ "ansi-fg" | "2" ] - [ "fg" | [ 102 204 255 ] ] + [[ "ansi-fg" "2" ]] + [[ "fg" [ 102 204 255 ] ]] ] "prettyprint" set-vocab-style [ - [ "ansi-fg" | "2" ] - [ "fg" | [ 0 0 0 ] ] + [[ "ansi-fg" "2" ]] + [[ "fg" [ 0 0 0 ] ]] ] "stack" set-vocab-style [ - [ "ansi-fg" | "4" ] - [ "fg" | [ 204 0 204 ] ] + [[ "ansi-fg" "4" ]] + [[ "fg" [ 204 0 204 ] ]] ] "stdio" set-vocab-style [ - [ "ansi-fg" | "4" ] - [ "fg" | [ 102 0 204 ] ] + [[ "ansi-fg" "4" ]] + [[ "fg" [ 102 0 204 ] ]] ] "streams" set-vocab-style [ - [ "ansi-fg" | "6" ] - [ "fg" | [ 255 0 204 ] ] + [[ "ansi-fg" "6" ]] + [[ "fg" [ 255 0 204 ] ]] ] "strings" set-vocab-style [ - [ "ansi-fg" | "4" ] - [ "fg" | [ 102 204 255 ] ] + [[ "ansi-fg" "4" ]] + [[ "fg" [ 102 204 255 ] ]] ] "unparser" set-vocab-style [ - [ "ansi-fg" | "3" ] - [ "fg" | [ 2 185 2 ] ] + [[ "ansi-fg" "3" ]] + [[ "fg" [ 2 185 2 ] ]] ] "vectors" set-vocab-style [ - [ "fg" | [ 128 128 128 ] ] + [[ "fg" [ 128 128 128 ] ]] ] "syntax" set-vocab-style diff --git a/library/sdl/sdl-keysym.factor b/library/sdl/sdl-keysym.factor index a12fead242..d66063fd48 100644 --- a/library/sdl/sdl-keysym.factor +++ b/library/sdl/sdl-keysym.factor @@ -34,263 +34,263 @@ USE: namespaces SYMBOL: modifiers [ - [ "SHIFT" | HEX: 0001 ] - [ "SHIFT" | HEX: 0002 ] - [ "CTRL" | HEX: 0040 ] - [ "CTRL" | HEX: 0080 ] - [ "ALT" | HEX: 0100 ] - [ "ALT" | HEX: 0200 ] - [ "META" | HEX: 0400 ] - [ "META" | HEX: 0800 ] - [ "NUM" | HEX: 1000 ] - [ "CAPS" | HEX: 2000 ] - [ "MODE" | HEX: 4000 ] + [[ "SHIFT" HEX: 0001 ]] + [[ "SHIFT" HEX: 0002 ]] + [[ "CTRL" HEX: 0040 ]] + [[ "CTRL" HEX: 0080 ]] + [[ "ALT" HEX: 0100 ]] + [[ "ALT" HEX: 0200 ]] + [[ "META" HEX: 0400 ]] + [[ "META" HEX: 0800 ]] + [[ "NUM" HEX: 1000 ]] + [[ "CAPS" HEX: 2000 ]] + [[ "MODE" HEX: 4000 ]] ] modifiers set SYMBOL: keysyms {{ ! The keyboard syms have been cleverly chosen to map to ASCII - [ 0 | "UNKNOWN" ] -! [ 0 | "FIRST" ] - [ 8 | "BACKSPACE" ] - [ 9 | "TAB" ] - [ 12 | "CLEAR" ] - [ 13 | "RETURN" ] - [ 19 | "PAUSE" ] - [ 27 | "ESCAPE" ] - [ 32 | "SPACE" ] - [ 33 | "EXCLAIM" ] - [ 34 | "QUOTEDBL" ] - [ 35 | "HASH" ] - [ 36 | "DOLLAR" ] - [ 38 | "AMPERSAND" ] - [ 39 | "QUOTE" ] - [ 40 | "LEFTPAREN" ] - [ 41 | "RIGHTPAREN" ] - [ 42 | "ASTERISK" ] - [ 43 | "PLUS" ] - [ 44 | "COMMA" ] - [ 45 | "MINUS" ] - [ 46 | "PERIOD" ] - [ 47 | "SLASH" ] - [ 48 | 0 ] - [ 49 | 1 ] - [ 50 | 2 ] - [ 51 | 3 ] - [ 52 | 4 ] - [ 53 | 5 ] - [ 54 | 6 ] - [ 55 | 7 ] - [ 56 | 8 ] - [ 57 | 9 ] - [ 58 | "COLON" ] - [ 59 | "SEMICOLON" ] - [ 60 | "LESS" ] - [ 61 | "EQUALS" ] - [ 62 | "GREATER" ] - [ 63 | "QUESTION" ] - [ 64 | "AT" ] + [[ 0 "UNKNOWN" ]] +! [[ 0 "FIRST" ]] + [[ 8 "BACKSPACE" ]] + [[ 9 "TAB" ]] + [[ 12 "CLEAR" ]] + [[ 13 "RETURN" ]] + [[ 19 "PAUSE" ]] + [[ 27 "ESCAPE" ]] + [[ 32 "SPACE" ]] + [[ 33 "EXCLAIM" ]] + [[ 34 "QUOTEDBL" ]] + [[ 35 "HASH" ]] + [[ 36 "DOLLAR" ]] + [[ 38 "AMPERSAND" ]] + [[ 39 "QUOTE" ]] + [[ 40 "LEFTPAREN" ]] + [[ 41 "RIGHTPAREN" ]] + [[ 42 "ASTERISK" ]] + [[ 43 "PLUS" ]] + [[ 44 "COMMA" ]] + [[ 45 "MINUS" ]] + [[ 46 "PERIOD" ]] + [[ 47 "SLASH" ]] + [[ 48 0 ]] + [[ 49 1 ]] + [[ 50 2 ]] + [[ 51 3 ]] + [[ 52 4 ]] + [[ 53 5 ]] + [[ 54 6 ]] + [[ 55 7 ]] + [[ 56 8 ]] + [[ 57 9 ]] + [[ 58 "COLON" ]] + [[ 59 "SEMICOLON" ]] + [[ 60 "LESS" ]] + [[ 61 "EQUALS" ]] + [[ 62 "GREATER" ]] + [[ 63 "QUESTION" ]] + [[ 64 "AT" ]] ! Skip uppercase letters - [ 91 | "LEFTBRACKET" ] - [ 92 | "BACKSLASH" ] - [ 93 | "RIGHTBRACKET" ] - [ 94 | "CARET" ] - [ 95 | "UNDERSCORE" ] - [ 96 | "BACKQUOTE" ] - [ 97 | "a" ] - [ 98 | "b" ] - [ 99 | "c" ] - [ 100 | "d" ] - [ 101 | "e" ] - [ 102 | "f" ] - [ 103 | "g" ] - [ 104 | "h" ] - [ 105 | "i" ] - [ 106 | "j" ] - [ 107 | "k" ] - [ 108 | "l" ] - [ 109 | "m" ] - [ 110 | "n" ] - [ 111 | "o" ] - [ 112 | "p" ] - [ 113 | "q" ] - [ 114 | "r" ] - [ 115 | "s" ] - [ 116 | "t" ] - [ 117 | "u" ] - [ 118 | "v" ] - [ 119 | "w" ] - [ 120 | "x" ] - [ 121 | "y" ] - [ 122 | "z" ] - [ 127 | "DELETE" ] + [[ 91 "LEFTBRACKET" ]] + [[ 92 "BACKSLASH" ]] + [[ 93 "RIGHTBRACKET" ]] + [[ 94 "CARET" ]] + [[ 95 "UNDERSCORE" ]] + [[ 96 "BACKQUOTE" ]] + [[ 97 "a" ]] + [[ 98 "b" ]] + [[ 99 "c" ]] + [[ 100 "d" ]] + [[ 101 "e" ]] + [[ 102 "f" ]] + [[ 103 "g" ]] + [[ 104 "h" ]] + [[ 105 "i" ]] + [[ 106 "j" ]] + [[ 107 "k" ]] + [[ 108 "l" ]] + [[ 109 "m" ]] + [[ 110 "n" ]] + [[ 111 "o" ]] + [[ 112 "p" ]] + [[ 113 "q" ]] + [[ 114 "r" ]] + [[ 115 "s" ]] + [[ 116 "t" ]] + [[ 117 "u" ]] + [[ 118 "v" ]] + [[ 119 "w" ]] + [[ 120 "x" ]] + [[ 121 "y" ]] + [[ 122 "z" ]] + [[ 127 "DELETE" ]] ! End of ASCII mapped keysyms ! International keyboard syms - [ 160 | "WORLD_0" ] ! 0xA0 - [ 161 | "WORLD_1" ] - [ 162 | "WORLD_2" ] - [ 163 | "WORLD_3" ] - [ 164 | "WORLD_4" ] - [ 165 | "WORLD_5" ] - [ 166 | "WORLD_6" ] - [ 167 | "WORLD_7" ] - [ 168 | "WORLD_8" ] - [ 169 | "WORLD_9" ] - [ 170 | "WORLD_10" ] - [ 171 | "WORLD_11" ] - [ 172 | "WORLD_12" ] - [ 173 | "WORLD_13" ] - [ 174 | "WORLD_14" ] - [ 175 | "WORLD_15" ] - [ 176 | "WORLD_16" ] - [ 177 | "WORLD_17" ] - [ 178 | "WORLD_18" ] - [ 179 | "WORLD_19" ] - [ 180 | "WORLD_20" ] - [ 181 | "WORLD_21" ] - [ 182 | "WORLD_22" ] - [ 183 | "WORLD_23" ] - [ 184 | "WORLD_24" ] - [ 185 | "WORLD_25" ] - [ 186 | "WORLD_26" ] - [ 187 | "WORLD_27" ] - [ 188 | "WORLD_28" ] - [ 189 | "WORLD_29" ] - [ 190 | "WORLD_30" ] - [ 191 | "WORLD_31" ] - [ 192 | "WORLD_32" ] - [ 193 | "WORLD_33" ] - [ 194 | "WORLD_34" ] - [ 195 | "WORLD_35" ] - [ 196 | "WORLD_36" ] - [ 197 | "WORLD_37" ] - [ 198 | "WORLD_38" ] - [ 199 | "WORLD_39" ] - [ 200 | "WORLD_40" ] - [ 201 | "WORLD_41" ] - [ 202 | "WORLD_42" ] - [ 203 | "WORLD_43" ] - [ 204 | "WORLD_44" ] - [ 205 | "WORLD_45" ] - [ 206 | "WORLD_46" ] - [ 207 | "WORLD_47" ] - [ 208 | "WORLD_48" ] - [ 209 | "WORLD_49" ] - [ 210 | "WORLD_50" ] - [ 211 | "WORLD_51" ] - [ 212 | "WORLD_52" ] - [ 213 | "WORLD_53" ] - [ 214 | "WORLD_54" ] - [ 215 | "WORLD_55" ] - [ 216 | "WORLD_56" ] - [ 217 | "WORLD_57" ] - [ 218 | "WORLD_58" ] - [ 219 | "WORLD_59" ] - [ 220 | "WORLD_60" ] - [ 221 | "WORLD_61" ] - [ 222 | "WORLD_62" ] - [ 223 | "WORLD_63" ] - [ 224 | "WORLD_64" ] - [ 225 | "WORLD_65" ] - [ 226 | "WORLD_66" ] - [ 227 | "WORLD_67" ] - [ 228 | "WORLD_68" ] - [ 229 | "WORLD_69" ] - [ 230 | "WORLD_70" ] - [ 231 | "WORLD_71" ] - [ 232 | "WORLD_72" ] - [ 233 | "WORLD_73" ] - [ 234 | "WORLD_74" ] - [ 235 | "WORLD_75" ] - [ 236 | "WORLD_76" ] - [ 237 | "WORLD_77" ] - [ 238 | "WORLD_78" ] - [ 239 | "WORLD_79" ] - [ 240 | "WORLD_80" ] - [ 241 | "WORLD_81" ] - [ 242 | "WORLD_82" ] - [ 243 | "WORLD_83" ] - [ 244 | "WORLD_84" ] - [ 245 | "WORLD_85" ] - [ 246 | "WORLD_86" ] - [ 247 | "WORLD_87" ] - [ 248 | "WORLD_88" ] - [ 249 | "WORLD_89" ] - [ 250 | "WORLD_90" ] - [ 251 | "WORLD_91" ] - [ 252 | "WORLD_92" ] - [ 253 | "WORLD_93" ] - [ 254 | "WORLD_94" ] - [ 255 | "WORLD_95" ] ! 0xFF + [[ 160 "WORLD_0" ]] ! 0xA0 + [[ 161 "WORLD_1" ]] + [[ 162 "WORLD_2" ]] + [[ 163 "WORLD_3" ]] + [[ 164 "WORLD_4" ]] + [[ 165 "WORLD_5" ]] + [[ 166 "WORLD_6" ]] + [[ 167 "WORLD_7" ]] + [[ 168 "WORLD_8" ]] + [[ 169 "WORLD_9" ]] + [[ 170 "WORLD_10" ]] + [[ 171 "WORLD_11" ]] + [[ 172 "WORLD_12" ]] + [[ 173 "WORLD_13" ]] + [[ 174 "WORLD_14" ]] + [[ 175 "WORLD_15" ]] + [[ 176 "WORLD_16" ]] + [[ 177 "WORLD_17" ]] + [[ 178 "WORLD_18" ]] + [[ 179 "WORLD_19" ]] + [[ 180 "WORLD_20" ]] + [[ 181 "WORLD_21" ]] + [[ 182 "WORLD_22" ]] + [[ 183 "WORLD_23" ]] + [[ 184 "WORLD_24" ]] + [[ 185 "WORLD_25" ]] + [[ 186 "WORLD_26" ]] + [[ 187 "WORLD_27" ]] + [[ 188 "WORLD_28" ]] + [[ 189 "WORLD_29" ]] + [[ 190 "WORLD_30" ]] + [[ 191 "WORLD_31" ]] + [[ 192 "WORLD_32" ]] + [[ 193 "WORLD_33" ]] + [[ 194 "WORLD_34" ]] + [[ 195 "WORLD_35" ]] + [[ 196 "WORLD_36" ]] + [[ 197 "WORLD_37" ]] + [[ 198 "WORLD_38" ]] + [[ 199 "WORLD_39" ]] + [[ 200 "WORLD_40" ]] + [[ 201 "WORLD_41" ]] + [[ 202 "WORLD_42" ]] + [[ 203 "WORLD_43" ]] + [[ 204 "WORLD_44" ]] + [[ 205 "WORLD_45" ]] + [[ 206 "WORLD_46" ]] + [[ 207 "WORLD_47" ]] + [[ 208 "WORLD_48" ]] + [[ 209 "WORLD_49" ]] + [[ 210 "WORLD_50" ]] + [[ 211 "WORLD_51" ]] + [[ 212 "WORLD_52" ]] + [[ 213 "WORLD_53" ]] + [[ 214 "WORLD_54" ]] + [[ 215 "WORLD_55" ]] + [[ 216 "WORLD_56" ]] + [[ 217 "WORLD_57" ]] + [[ 218 "WORLD_58" ]] + [[ 219 "WORLD_59" ]] + [[ 220 "WORLD_60" ]] + [[ 221 "WORLD_61" ]] + [[ 222 "WORLD_62" ]] + [[ 223 "WORLD_63" ]] + [[ 224 "WORLD_64" ]] + [[ 225 "WORLD_65" ]] + [[ 226 "WORLD_66" ]] + [[ 227 "WORLD_67" ]] + [[ 228 "WORLD_68" ]] + [[ 229 "WORLD_69" ]] + [[ 230 "WORLD_70" ]] + [[ 231 "WORLD_71" ]] + [[ 232 "WORLD_72" ]] + [[ 233 "WORLD_73" ]] + [[ 234 "WORLD_74" ]] + [[ 235 "WORLD_75" ]] + [[ 236 "WORLD_76" ]] + [[ 237 "WORLD_77" ]] + [[ 238 "WORLD_78" ]] + [[ 239 "WORLD_79" ]] + [[ 240 "WORLD_80" ]] + [[ 241 "WORLD_81" ]] + [[ 242 "WORLD_82" ]] + [[ 243 "WORLD_83" ]] + [[ 244 "WORLD_84" ]] + [[ 245 "WORLD_85" ]] + [[ 246 "WORLD_86" ]] + [[ 247 "WORLD_87" ]] + [[ 248 "WORLD_88" ]] + [[ 249 "WORLD_89" ]] + [[ 250 "WORLD_90" ]] + [[ 251 "WORLD_91" ]] + [[ 252 "WORLD_92" ]] + [[ 253 "WORLD_93" ]] + [[ 254 "WORLD_94" ]] + [[ 255 "WORLD_95" ]] ! 0xFF ! Numeric keypad - [ 256 | "KP0" ] - [ 257 | "KP1" ] - [ 258 | "KP2" ] - [ 259 | "KP3" ] - [ 260 | "KP4" ] - [ 261 | "KP5" ] - [ 262 | "KP6" ] - [ 263 | "KP7" ] - [ 264 | "KP8" ] - [ 265 | "KP9" ] - [ 266 | "KP_PERIOD" ] - [ 267 | "KP_DIVIDE" ] - [ 268 | "KP_MULTIPLY" ] - [ 269 | "KP_MINUS" ] - [ 270 | "KP_PLUS" ] - [ 271 | "KP_ENTER" ] - [ 272 | "KP_EQUALS" ] + [[ 256 "KP0" ]] + [[ 257 "KP1" ]] + [[ 258 "KP2" ]] + [[ 259 "KP3" ]] + [[ 260 "KP4" ]] + [[ 261 "KP5" ]] + [[ 262 "KP6" ]] + [[ 263 "KP7" ]] + [[ 264 "KP8" ]] + [[ 265 "KP9" ]] + [[ 266 "KP_PERIOD" ]] + [[ 267 "KP_DIVIDE" ]] + [[ 268 "KP_MULTIPLY" ]] + [[ 269 "KP_MINUS" ]] + [[ 270 "KP_PLUS" ]] + [[ 271 "KP_ENTER" ]] + [[ 272 "KP_EQUALS" ]] ! Arrows + Home/End pad - [ 273 | "UP" ] - [ 274 | "DOWN" ] - [ 275 | "RIGHT" ] - [ 276 | "LEFT" ] - [ 277 | "INSERT" ] - [ 278 | "HOME" ] - [ 279 | "END" ] - [ 280 | "PAGEUP" ] - [ 281 | "PAGEDOWN" ] + [[ 273 "UP" ]] + [[ 274 "DOWN" ]] + [[ 275 "RIGHT" ]] + [[ 276 "LEFT" ]] + [[ 277 "INSERT" ]] + [[ 278 "HOME" ]] + [[ 279 "END" ]] + [[ 280 "PAGEUP" ]] + [[ 281 "PAGEDOWN" ]] ! Function keys - [ 282 | "F1" ] - [ 283 | "F2" ] - [ 284 | "F3" ] - [ 285 | "F4" ] - [ 286 | "F5" ] - [ 287 | "F6" ] - [ 288 | "F7" ] - [ 289 | "F8" ] - [ 290 | "F9" ] - [ 291 | "F10" ] - [ 292 | "F11" ] - [ 293 | "F12" ] - [ 294 | "F13" ] - [ 295 | "F14" ] - [ 296 | "F15" ] + [[ 282 "F1" ]] + [[ 283 "F2" ]] + [[ 284 "F3" ]] + [[ 285 "F4" ]] + [[ 286 "F5" ]] + [[ 287 "F6" ]] + [[ 288 "F7" ]] + [[ 289 "F8" ]] + [[ 290 "F9" ]] + [[ 291 "F10" ]] + [[ 292 "F11" ]] + [[ 293 "F12" ]] + [[ 294 "F13" ]] + [[ 295 "F14" ]] + [[ 296 "F15" ]] ! Key state modifier keys - [ 300 | "NUMLOCK" ] - [ 301 | "CAPSLOCK" ] - [ 302 | "SCROLLOCK" ] - [ 303 | "RSHIFT" ] - [ 304 | "LSHIFT" ] - [ 305 | "RCTRL" ] - [ 306 | "LCTRL" ] - [ 307 | "RALT" ] - [ 308 | "LALT" ] - [ 309 | "RMETA" ] - [ 310 | "LMETA" ] - [ 311 | "LSUPER" ] ! Left "Windows" key - [ 312 | "RSUPER" ] ! Right "Windows" key - [ 313 | "MODE" ] ! "Alt Gr" key - [ 314 | "COMPOSE" ] ! Multi-key compose key + [[ 300 "NUMLOCK" ]] + [[ 301 "CAPSLOCK" ]] + [[ 302 "SCROLLOCK" ]] + [[ 303 "RSHIFT" ]] + [[ 304 "LSHIFT" ]] + [[ 305 "RCTRL" ]] + [[ 306 "LCTRL" ]] + [[ 307 "RALT" ]] + [[ 308 "LALT" ]] + [[ 309 "RMETA" ]] + [[ 310 "LMETA" ]] + [[ 311 "LSUPER" ]] ! Left "Windows" key + [[ 312 "RSUPER" ]] ! Right "Windows" key + [[ 313 "MODE" ]] ! "Alt Gr" key + [[ 314 "COMPOSE" ]] ! Multi-key compose key ! Miscellaneous function keys - [ 315 | "HELP" ] - [ 316 | "PRINT" ] - [ 317 | "SYSREQ" ] - [ 318 | "BREAK" ] - [ 319 | "MENU" ] - [ 320 | "POWER" ] ! Power Macintosh power key - [ 321 | "EURO" ] ! Some european keyboards - [ 322 | "UNDO" ] ! Atari keyboard has Undo + [[ 315 "HELP" ]] + [[ 316 "PRINT" ]] + [[ 317 "SYSREQ" ]] + [[ 318 "BREAK" ]] + [[ 319 "MENU" ]] + [[ 320 "POWER" ]] ! Power Macintosh power key + [[ 321 "EURO" ]] ! Some european keyboards + [[ 322 "UNDO" ]] ! Atari keyboard has Undo ! Add any other keys here }} keysyms set diff --git a/library/syntax/parse-syntax.factor b/library/syntax/parse-syntax.factor index b17e74006e..d20992b784 100644 --- a/library/syntax/parse-syntax.factor +++ b/library/syntax/parse-syntax.factor @@ -56,28 +56,27 @@ USE: unparser ! properties to the current word if it is set. ! Constants -: t t parsed ; parsing -: f f parsed ; parsing +: t t swons ; parsing +: f f swons ; parsing ! Lists : [ f ; parsing -: ] reverse parsed ; parsing +: ] reverse swons ; parsing -: | ( syntax: | cdr ] ) - #! See the word 'parsed'. We push a special sentinel, and - #! 'parsed' acts accordingly. - "|" ; parsing +! Conses (whose cdr might not be a list) +: [[ f ; parsing +: ]] 2unlist swons swons ; parsing ! Vectors : { f ; parsing -: } reverse list>vector parsed ; parsing +: } reverse list>vector swons ; parsing ! Hashtables : {{ f ; parsing -: }} alist>hash parsed ; parsing +: }} alist>hash swons ; parsing ! Do not execute parsing word -: POSTPONE: ( -- ) scan-word parsed ; parsing +: POSTPONE: ( -- ) scan-word swons ; parsing : : #! Begin a word definition. Word name follows. @@ -95,7 +94,7 @@ USE: unparser : \ #! Parsed as a piece of code that pushes a word on the stack #! \ foo ==> [ foo ] car - scan-word unit parsed \ car parsed ; parsing + scan-word unit swons \ car swons ; parsing ! Vocabularies : DEFER: @@ -112,7 +111,7 @@ USE: unparser scan dup "use" cons@ "in" set ; parsing ! Char literal -: CHAR: ( -- ) next-word-ch parse-ch parsed ; parsing +: CHAR: ( -- ) next-word-ch parse-ch swons ; parsing ! String literal : parse-string ( -- ) @@ -126,11 +125,14 @@ USE: unparser #! Note the ugly hack to carry the new value of 'pos' from #! the make-string scope up to the original scope. [ parse-string "col" get ] make-string - swap "col" set parsed ; parsing + swap "col" set swons ; parsing + +: expect ( word -- ) + dup scan = [ drop ] [ "Expected " swap cat2 throw ] ifte ; : #{ #! Complex literal - #{ real imaginary #} - scan str>number scan str>number rect> "}" expect parsed ; + scan str>number scan str>number rect> "}" expect swons ; parsing ! Comments @@ -148,11 +150,11 @@ USE: unparser ! Reading numbers in other bases -: BASE: ( base -- ) +: (BASE) ( base -- ) #! Read a number in a specific base. - scan swap base> parsed ; + scan swap base> swons ; -: HEX: 16 BASE: ; parsing -: DEC: 10 BASE: ; parsing -: OCT: 8 BASE: ; parsing -: BIN: 2 BASE: ; parsing +: HEX: 16 (BASE) ; parsing +: DEC: 10 (BASE) ; parsing +: OCT: 8 (BASE) ; parsing +: BIN: 2 (BASE) ; parsing diff --git a/library/syntax/parser.factor b/library/syntax/parser.factor index 6518079173..6c50d406ea 100644 --- a/library/syntax/parser.factor +++ b/library/syntax/parser.factor @@ -118,20 +118,10 @@ USE: unparser dup "use" get search [ str>number ] ?unless ] when ; -: parsed| ( parsed parsed obj -- parsed ) - #! Some ugly ugly code to handle [ a | b ] expressions. - >r unswons r> cons swap [ swons ] each swons ; - -: expect ( word -- ) - dup scan = [ drop ] [ "Expected " swap cat2 throw ] ifte ; - -: parsed ( obj -- ) - over "|" = [ nip parsed| "]" expect ] [ swons ] ifte ; - : (parse) ( str -- ) [ scan-word [ - dup parsing? [ execute ] [ parsed ] ifte + dup parsing? [ execute ] [ swons ] ifte ] when* ] with-parser ; @@ -185,15 +175,15 @@ USE: unparser : ascii-escape>ch ( ch -- esc ) [ - [ CHAR: e | CHAR: \e ] - [ CHAR: n | CHAR: \n ] - [ CHAR: r | CHAR: \r ] - [ CHAR: t | CHAR: \t ] - [ CHAR: s | CHAR: \s ] - [ CHAR: \s | CHAR: \s ] - [ CHAR: 0 | CHAR: \0 ] - [ CHAR: \\ | CHAR: \\ ] - [ CHAR: \" | CHAR: \" ] + [[ CHAR: e CHAR: \e ]] + [[ CHAR: n CHAR: \n ]] + [[ CHAR: r CHAR: \r ]] + [[ CHAR: t CHAR: \t ]] + [[ CHAR: s CHAR: \s ]] + [[ CHAR: \s CHAR: \s ]] + [[ CHAR: 0 CHAR: \0 ]] + [[ CHAR: \\ CHAR: \\ ]] + [[ CHAR: \" CHAR: \" ]] ] assoc ; : escape ( ch -- esc ) diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index a68c20793f..11fd9c179d 100644 --- a/library/syntax/prettyprint.factor +++ b/library/syntax/prettyprint.factor @@ -89,11 +89,11 @@ M: object prettyprint* ( indent obj -- indent ) : word-actions ( search -- list ) [ - [ "See" | "see" ] - [ "Push" | "" ] - [ "Execute" | "execute" ] - [ "jEdit" | "jedit" ] - [ "Usages" | "usages." ] + [[ "See" "see" ]] + [[ "Push" "" ]] + [[ "Execute" "execute" ]] + [[ "jEdit" "jedit" ]] + [[ "Usages" "usages." ]] ] ; : word-attrs ( word -- attrs ) @@ -118,21 +118,16 @@ M: word prettyprint* ( indent word -- indent ) : prettyprint-list ( indent list -- indent ) #! Pretty-print a list, without [ and ]. - [ - uncons >r prettyprint-element r> - dup cons? [ - prettyprint-list - ] [ - [ - \ | prettyprint* - " " write prettyprint-element - ] when* - ] ifte - ] when* ; + [ prettyprint-element ] each ; -M: cons prettyprint* ( indent list -- indent ) +M: list prettyprint* ( indent list -- indent ) swap prettyprint-[ swap prettyprint-list prettyprint-] ; +M: cons prettyprint* ( indent cons -- indent ) + \ [[ prettyprint* " " write + uncons >r prettyprint-element r> prettyprint-element + \ ]] prettyprint* ; + : prettyprint-{ ( indent -- indent ) \ { prettyprint* ascii-escape ( ch -- esc ) [ - [ CHAR: \e | "\\e" ] - [ CHAR: \n | "\\n" ] - [ CHAR: \r | "\\r" ] - [ CHAR: \t | "\\t" ] - [ CHAR: \0 | "\\0" ] - [ CHAR: \\ | "\\\\" ] - [ CHAR: \" | "\\\"" ] + [[ CHAR: \e "\\e" ]] + [[ CHAR: \n "\\n" ]] + [[ CHAR: \r "\\r" ]] + [[ CHAR: \t "\\t" ]] + [[ CHAR: \0 "\\0" ]] + [[ CHAR: \\ "\\\\" ]] + [[ CHAR: \" "\\\"" ]] ] assoc ; : ch>unicode-escape ( ch -- esc ) diff --git a/library/test/alien.factor b/library/test/alien.factor index fec1163c50..fec3cb3e08 100644 --- a/library/test/alien.factor +++ b/library/test/alien.factor @@ -14,9 +14,9 @@ USE: inference : alien-inference-1 "void" "foobar" "boo" [ "short" "short" ] alien-invoke ; -[ [ 2 | 0 ] ] [ [ alien-inference-1 ] infer old-effect ] unit-test +[ [[ 2 0 ]] ] [ [ alien-inference-1 ] infer old-effect ] unit-test : alien-inference-2 "int" "foobar" "boo" [ "short" "short" ] alien-invoke ; -[ [ 2 | 1 ] ] [ [ alien-inference-2 ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ alien-inference-2 ] infer old-effect ] unit-test diff --git a/library/test/benchmark/sort.factor b/library/test/benchmark/sort.factor index 55a8c9ae30..04448a9b44 100644 --- a/library/test/benchmark/sort.factor +++ b/library/test/benchmark/sort.factor @@ -2,6 +2,7 @@ IN: scratchpad USE: lists USE: kernel USE: math +USE: namespaces USE: random USE: test USE: compiler diff --git a/library/test/benchmark/strings.factor b/library/test/benchmark/strings.factor index bf12d7390e..6308741eae 100644 --- a/library/test/benchmark/strings.factor +++ b/library/test/benchmark/strings.factor @@ -3,6 +3,7 @@ USE: kernel USE: math USE: test USE: lists +USE: namespaces USE: compiler ! http://inferno.bell-labs.com/cm/cs/who/bwk/interps/pap.html diff --git a/library/test/compiler/optimizer.factor b/library/test/compiler/optimizer.factor index 82b33536fc..7d592684d1 100644 --- a/library/test/compiler/optimizer.factor +++ b/library/test/compiler/optimizer.factor @@ -9,12 +9,12 @@ USE: lists : foo 1 2 3 ; -[ [ ] ] [ \ foo word-parameter dataflow kill-set ] unit-test - -[ [ [ + ] [ - ] ] ] [ [ 3 4 1 2 > [ + ] [ - ] ifte ] dataflow kill-set ] unit-test - -[ [ [ 1 ] [ 2 ] ] ] [ [ [ 1 ] [ 2 ] ifte ] dataflow kill-set ] unit-test - -[ [ [ 1 ] [ 2 ] ] ] [ [ t [ 1 ] [ 2 ] ifte ] dataflow kill-set ] unit-test - -[ [ t t f ] ] [ [ 1 2 ] [ 1 2 3 ] [ f ] map kill-mask ] unit-test +! [ [ ] ] [ \ foo word-parameter dataflow kill-set ] unit-test +! +! [ [ [ + ] [ - ] ] ] [ [ 3 4 1 2 > [ + ] [ - ] ifte ] dataflow kill-set ] unit-test +! +! [ [ [ 1 ] [ 2 ] ] ] [ [ [ 1 ] [ 2 ] ifte ] dataflow kill-set ] unit-test +! +! [ [ [ 1 ] [ 2 ] ] ] [ [ t [ 1 ] [ 2 ] ifte ] dataflow kill-set ] unit-test +! +! [ [ t t f ] ] [ [ 1 2 ] [ 1 2 3 ] [ f ] map kill-mask ] unit-test diff --git a/library/test/compiler/simplifier.factor b/library/test/compiler/simplifier.factor index a1ed0ce704..8b9876555d 100644 --- a/library/test/compiler/simplifier.factor +++ b/library/test/compiler/simplifier.factor @@ -7,35 +7,35 @@ USE: kernel [ [ ] ] [ [ ] simplify ] unit-test [ [ [ #return ] ] ] [ [ [ #return ] ] simplify ] unit-test -[ [ #jump | car ] ] [ [ [ #call | car ] [ #return ] ] simplify car ] unit-test +[ [[ #jump car ]] ] [ [ [[ #call car ]] [ #return ] ] simplify car ] unit-test [ [ [ #return ] ] ] -[ 123 [ [ #call | car ] [ #label | 123 ] [ #return ] ] find-label ] +[ 123 [ [[ #call car ]] [[ #label 123 ]] [ #return ] ] find-label ] unit-test [ [ [ #return ] ] ] -[ [ [ #label | 123 ] [ #return ] ] follow ] +[ [ [[ #label 123 ]] [ #return ] ] follow ] unit-test [ [ [ #return ] ] ] [ [ - [ #jump-label | 123 ] - [ #call | car ] - [ #label | 123 ] + [[ #jump-label 123 ]] + [[ #call car ]] + [[ #label 123 ]] [ #return ] ] follow ] unit-test [ - [ #jump | car ] + [[ #jump car ]] ] [ [ - [ #call | car ] - [ #jump-label | 123 ] - [ #label | 123 ] + [[ #call car ]] + [[ #jump-label 123 ]] + [[ #label 123 ]] [ #return ] ] simplify car ] unit-test @@ -44,13 +44,13 @@ unit-test t ] [ [ - [ #push-immediate | 1 ] + [[ #push-immediate 1 ]] ] push-next? >boolean ] unit-test [ [ - [ #replace-immediate | 1 ] + [[ #replace-immediate 1 ]] [ #return ] ] ] [ diff --git a/library/test/dataflow.factor b/library/test/dataflow.factor index 07afb2df1e..40c42f8f58 100644 --- a/library/test/dataflow.factor +++ b/library/test/dataflow.factor @@ -58,7 +58,7 @@ USE: generic #ifte swap dataflow-contains-op? car [ node-consume-d get ] bind ; [ t ] [ - [ 2 [ swap ] [ nip "hi" ] ifte ] dataflow + [ [ swap ] [ nip "hi" ] ifte ] dataflow dataflow-ifte-node-consume-d length 1 = ] unit-test @@ -77,8 +77,8 @@ SYMBOL: #test [ 6 ] [ {{ - [ node-op | #test ] - [ node-param | 5 ] + [[ node-op #test ]] + [[ node-param 5 ]] }} "foobar" [ [ node-param get ] bind 1 + ] apply-dataflow ] unit-test @@ -86,8 +86,8 @@ SYMBOL: #test [ 25 ] [ {{ - [ node-op | #test ] - [ node-param | 5 ] + [[ node-op #test ]] + [[ node-param 5 ]] }} "foobar" [ [ node-param get ] bind 1 + ] apply-dataflow ] unit-test diff --git a/library/test/generic.factor b/library/test/generic.factor index 404f513466..8dafd24d5e 100644 --- a/library/test/generic.factor +++ b/library/test/generic.factor @@ -86,8 +86,8 @@ M: f bool>str drop "false" ; : str>bool [ - [ "true" | t ] - [ "false" | f ] + [[ "true" t ]] + [[ "false" f ]] ] assoc ; [ t ] [ t bool>str str>bool ] unit-test @@ -99,7 +99,7 @@ GENERIC: funny-length M: cons funny-length drop 0 ; M: nonempty-list funny-length length ; -[ 0 ] [ [ 1 2 | 3 ] funny-length ] unit-test +[ 0 ] [ [[ 1 [[ 2 3 ]] ]] funny-length ] unit-test [ 3 ] [ [ 1 2 3 ] funny-length ] unit-test [ "hello" funny-length ] unit-test-fails diff --git a/library/test/hashtables.factor b/library/test/hashtables.factor index d0cf97e16c..c951e54669 100644 --- a/library/test/hashtables.factor +++ b/library/test/hashtables.factor @@ -22,13 +22,13 @@ unit-test unit-test [ f ] -[ [ 1 2 | 3 ] hashtable? ] +[ [[ 1 [[ 2 3 ]] ]] hashtable? ] unit-test ! Test some hashcodes. [ t ] [ [ 1 2 3 ] hashcode [ 1 2 3 ] hashcode = ] unit-test -[ t ] [ [ f | t ] hashcode [ f | t ] hashcode = ] unit-test +[ t ] [ [[ f t ]] hashcode [[ f t ]] hashcode = ] unit-test [ t ] [ [ 1 [ 2 3 ] 4 ] hashcode [ 1 [ 2 3 ] 4 ] hashcode = ] unit-test [ t ] [ 12 hashcode 12 hashcode = ] unit-test @@ -48,10 +48,10 @@ f 100 fac "testhash" get set-hash [ { } ] [ { [ { } ] } vector-clone "testhash" get hash* cdr ] unit-test [ - [ "salmon" | "fish" ] - [ "crocodile" | "reptile" ] - [ "cow" | "mammal" ] - [ "visual basic" | "language" ] + [[ "salmon" "fish" ]] + [[ "crocodile" "reptile" ]] + [[ "cow" "mammal" ]] + [[ "visual basic" "language" ]] ] alist>hash "testhash" set [ f ] [ diff --git a/library/test/httpd/html.factor b/library/test/httpd/html.factor index 912b5fd3ff..cb84e8894e 100644 --- a/library/test/httpd/html.factor +++ b/library/test/httpd/html.factor @@ -23,7 +23,7 @@ USE: kernel [ [ "" - [ [ "icon" | "library/icons/File.png" ] ] + [ [[ "icon" "library/icons/File.png" ]] ] [ drop ] icon-tag ] with-string ] unit-test @@ -38,7 +38,7 @@ USE: kernel [ "car" ] [ [ - [ [ "fg" 255 0 255 ] [ "font" | "Monospaced" ] ] + [ [ "fg" 255 0 255 ] [[ "font" "Monospaced" ]] ] [ drop "car" write ] span-tag ] with-string @@ -56,7 +56,7 @@ USE: kernel [ [ "car" - [ [ "fg" 255 0 255 ] [ "font" | "Monospaced" ] ] + [ [ "fg" 255 0 255 ] [[ "font" "Monospaced" ]] ] html-write-attr ] with-string ] unit-test diff --git a/library/test/httpd/httpd.factor b/library/test/httpd/httpd.factor index 3ad02eee91..94409070fe 100644 --- a/library/test/httpd/httpd.factor +++ b/library/test/httpd/httpd.factor @@ -20,12 +20,12 @@ USE: lists [ [ - [ "X-Spyware-Requested" | "yes" ] - [ "User-Agent" | "Internet Explorer 0.4alpha" ] + [[ "X-Spyware-Requested" "yes" ]] + [[ "User-Agent" "Internet Explorer 0.4alpha" ]] ] ] [ - [ [ "User-Agent" | "Internet Explorer 0.4alpha" ] ] + [ [[ "User-Agent" "Internet Explorer 0.4alpha" ]] ] "X-Spyware-Requested: yes" header-line ] unit-test @@ -67,12 +67,12 @@ USE: lists [ ] [ "GET ../index.html" parse-request ] unit-test [ ] [ "POO" parse-request ] unit-test -[ [ [ "Foo" | "Bar" ] ] ] [ "Foo=Bar" query>alist ] unit-test +[ [ [[ "Foo" "Bar" ]] ] ] [ "Foo=Bar" query>alist ] unit-test -[ [ [ "Foo" | "Bar" ] [ "Baz" | "Quux" ] ] ] +[ [ [[ "Foo" "Bar" ]] [[ "Baz" "Quux" ]] ] ] [ "Foo=Bar&Baz=Quux" query>alist ] unit-test -[ [ [ "Baz" | " " ] ] ] +[ [ [[ "Baz" " " ]] ] ] [ "Baz=%20" query>alist ] unit-test [ [ [ "Foo" ] ] ] [ "Foo" query>alist ] unit-test diff --git a/library/test/inference.factor b/library/test/inference.factor index 31ab36ece6..a042efab5c 100644 --- a/library/test/inference.factor +++ b/library/test/inference.factor @@ -29,25 +29,25 @@ USE: generic ! decompose ! ] unit-test -: old-effect ( [ in-types out-types ] -- [ in | out ] ) +: old-effect ( [ in-types out-types ] -- [[ in out ]] ) uncons car length >r length r> cons ; -[ [ 0 | 2 ] ] [ [ 2 "Hello" ] infer old-effect ] unit-test -[ [ 1 | 2 ] ] [ [ dup ] infer old-effect ] unit-test +[ [[ 0 2 ]] ] [ [ 2 "Hello" ] infer old-effect ] unit-test +[ [[ 1 2 ]] ] [ [ dup ] infer old-effect ] unit-test -[ [ 1 | 2 ] ] [ [ [ dup ] call ] infer old-effect ] unit-test +[ [[ 1 2 ]] ] [ [ [ dup ] call ] infer old-effect ] unit-test [ [ call ] infer old-effect ] unit-test-fails -[ [ 2 | 4 ] ] [ [ 2dup ] infer old-effect ] unit-test -[ [ 2 | 0 ] ] [ [ vector-push ] infer old-effect ] unit-test +[ [[ 2 4 ]] ] [ [ 2dup ] infer old-effect ] unit-test +[ [[ 2 0 ]] ] [ [ vector-push ] infer old-effect ] unit-test -[ [ 1 | 0 ] ] [ [ [ ] [ ] ifte ] infer old-effect ] unit-test +[ [[ 1 0 ]] ] [ [ [ ] [ ] ifte ] infer old-effect ] unit-test [ [ ifte ] infer old-effect ] unit-test-fails [ [ [ ] ifte ] infer old-effect ] unit-test-fails [ [ [ 2 ] [ ] ifte ] infer old-effect ] unit-test-fails -[ [ 4 | 3 ] ] [ [ [ rot ] [ -rot ] ifte ] infer old-effect ] unit-test +[ [[ 4 3 ]] ] [ [ [ rot ] [ -rot ] ifte ] infer old-effect ] unit-test -[ [ 4 | 3 ] ] [ +[ [[ 4 3 ]] ] [ [ [ [ swap 3 ] [ nip 5 5 ] ifte @@ -57,14 +57,14 @@ USE: generic ] infer old-effect ] unit-test -[ [ 1 | 1 ] ] [ [ dup [ ] when ] infer old-effect ] unit-test -[ [ 1 | 1 ] ] [ [ dup [ dup fixnum* ] when ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ [ dup fixnum* ] when ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ dup [ ] when ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ dup [ dup fixnum* ] when ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ [ dup fixnum* ] when ] infer old-effect ] unit-test -[ [ 1 | 0 ] ] [ [ [ drop ] when* ] infer old-effect ] unit-test -[ [ 1 | 1 ] ] [ [ [ { { [ ] } } ] unless* ] infer old-effect ] unit-test +[ [[ 1 0 ]] ] [ [ [ drop ] when* ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ [ { { [ ] } } ] unless* ] infer old-effect ] unit-test -[ [ 0 | 1 ] ] [ +[ [[ 0 1 ]] ] [ [ [ 2 2 fixnum+ ] dup [ ] when call ] infer old-effect ] unit-test @@ -79,12 +79,12 @@ USE: generic : simple-recursion-1 dup [ simple-recursion-1 ] [ ] ifte ; -[ [ 1 | 1 ] ] [ [ simple-recursion-1 ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ simple-recursion-1 ] infer old-effect ] unit-test : simple-recursion-2 dup [ ] [ simple-recursion-2 ] ifte ; -[ [ 1 | 1 ] ] [ [ simple-recursion-2 ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ simple-recursion-2 ] infer old-effect ] unit-test ! : bad-recursion-1 ! dup [ drop bad-recursion-1 5 ] [ ] ifte ; @@ -101,10 +101,10 @@ USE: generic : funny-recursion dup [ funny-recursion 1 ] [ 2 ] ifte drop ; -[ [ 1 | 1 ] ] [ [ funny-recursion ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ funny-recursion ] infer old-effect ] unit-test ! Simple combinators -[ [ 1 | 2 ] ] [ [ [ car ] keep cdr ] infer old-effect ] unit-test +[ [[ 1 2 ]] ] [ [ [ car ] keep cdr ] infer old-effect ] unit-test ! Mutual recursion DEFER: foe @@ -127,8 +127,8 @@ DEFER: foe 2drop f ] ifte ; -[ [ 2 | 1 ] ] [ [ fie ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ foe ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ fie ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ foe ] infer old-effect ] unit-test ! This form should not have a stack effect ! : bad-bin 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] ifte ; @@ -141,7 +141,7 @@ DEFER: foe ] when ] when ; -[ [ 0 | 0 ] ] [ [ nested-when ] infer old-effect ] unit-test +[ [[ 0 0 ]] ] [ [ nested-when ] infer old-effect ] unit-test : nested-when* ( -- ) [ @@ -150,55 +150,55 @@ DEFER: foe ] when* ] when* ; -[ [ 1 | 0 ] ] [ [ nested-when* ] infer old-effect ] unit-test +[ [[ 1 0 ]] ] [ [ nested-when* ] infer old-effect ] unit-test SYMBOL: sym-test -[ [ 0 | 1 ] ] [ [ sym-test ] infer old-effect ] unit-test +[ [[ 0 1 ]] ] [ [ sym-test ] infer old-effect ] unit-test -[ [ 2 | 0 ] ] [ [ set-vector-length ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ 2list ] infer old-effect ] unit-test -[ [ 3 | 1 ] ] [ [ 3list ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ append ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ swons ] infer old-effect ] unit-test -[ [ 1 | 2 ] ] [ [ uncons ] infer old-effect ] unit-test -[ [ 1 | 1 ] ] [ [ unit ] infer old-effect ] unit-test -[ [ 1 | 2 ] ] [ [ unswons ] infer old-effect ] unit-test -[ [ 1 | 1 ] ] [ [ last* ] infer old-effect ] unit-test -[ [ 1 | 1 ] ] [ [ last ] infer old-effect ] unit-test -[ [ 1 | 1 ] ] [ [ list? ] infer old-effect ] unit-test +[ [[ 2 0 ]] ] [ [ set-vector-length ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ 2list ] infer old-effect ] unit-test +[ [[ 3 1 ]] ] [ [ 3list ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ append ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ swons ] infer old-effect ] unit-test +[ [[ 1 2 ]] ] [ [ uncons ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ unit ] infer old-effect ] unit-test +[ [[ 1 2 ]] ] [ [ unswons ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ last* ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ last ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ list? ] infer old-effect ] unit-test -[ [ 1 | 1 ] ] [ [ length ] infer old-effect ] unit-test -[ [ 1 | 1 ] ] [ [ reverse ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ contains? ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ tree-contains? ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ remove ] infer old-effect ] unit-test -[ [ 1 | 1 ] ] [ [ prune ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ length ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ reverse ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ contains? ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ tree-contains? ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ remove ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ prune ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ bitor ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ bitand ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ bitxor ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ mod ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ /i ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ /f ] infer old-effect ] unit-test -[ [ 2 | 2 ] ] [ [ /mod ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ + ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ - ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ * ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ / ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ < ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ <= ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ > ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ >= ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ number= ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ bitor ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ bitand ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ bitxor ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ mod ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ /i ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ /f ] infer old-effect ] unit-test +[ [[ 2 2 ]] ] [ [ /mod ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ + ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ - ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ * ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ / ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ < ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ <= ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ > ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ >= ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ number= ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ = ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ = ] infer old-effect ] unit-test -[ [ 1 | 0 ] ] [ [ >n ] infer old-effect ] unit-test -[ [ 0 | 1 ] ] [ [ n> ] infer old-effect ] unit-test +[ [[ 1 0 ]] ] [ [ >n ] infer old-effect ] unit-test +[ [[ 0 1 ]] ] [ [ n> ] infer old-effect ] unit-test -[ [ 1 | 1 ] ] [ [ get ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ get ] infer old-effect ] unit-test : terminator-branch dup [ @@ -207,9 +207,9 @@ SYMBOL: sym-test not-a-number ] ifte ; -[ [ 1 | 1 ] ] [ [ terminator-branch ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ terminator-branch ] infer old-effect ] unit-test -[ [ 1 | 1 ] ] [ [ str>number ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ str>number ] infer old-effect ] unit-test ! Type inference diff --git a/library/test/interpreter.factor b/library/test/interpreter.factor index e4cd6371da..19fdcc01c2 100644 --- a/library/test/interpreter.factor +++ b/library/test/interpreter.factor @@ -33,7 +33,7 @@ USE: kernel ] unit-test [ { "Hey" "there" } ] [ - [ [ "Hey" | "there" ] uncons ] test-interpreter + [ [[ "Hey" "there" ]] uncons ] test-interpreter ] unit-test [ { t } ] [ diff --git a/library/test/lists/assoc.factor b/library/test/lists/assoc.factor index 386018deec..c758313cab 100644 --- a/library/test/lists/assoc.factor +++ b/library/test/lists/assoc.factor @@ -5,16 +5,16 @@ USE: namespaces USE: test [ - [ "monkey" | 1 ] - [ "banana" | 2 ] - [ "Java" | 3 ] - [ t | "true" ] - [ f | "false" ] - [ [ 1 2 ] | [ 2 1 ] ] + [[ "monkey" 1 ]] + [[ "banana" 2 ]] + [[ "Java" 3 ]] + [[ t "true" ]] + [[ f "false" ]] + [[ [ 1 2 ] [ 2 1 ] ]] ] "assoc" set [ t ] [ "assoc" get assoc? ] unit-test -[ f ] [ [ 1 2 3 | 4 ] assoc? ] unit-test +[ f ] [ [[ 1 [[ 2 [[ 3 4 ]] ]] ]] assoc? ] unit-test [ f ] [ "assoc" assoc? ] unit-test [ f ] [ "monkey" f assoc ] unit-test @@ -28,9 +28,9 @@ USE: test [ "is great" ] [ "Java" "assoc" get assoc ] unit-test [ - [ "one" | 1 ] - [ "two" | 2 ] - [ "four" | 4 ] + [[ "one" 1 ]] + [[ "two" 2 ]] + [[ "four" 4 ]] ] "value-alist" set [ diff --git a/library/test/lists/cons.factor b/library/test/lists/cons.factor index 47bd64dad4..f152daa4fb 100644 --- a/library/test/lists/cons.factor +++ b/library/test/lists/cons.factor @@ -7,28 +7,28 @@ USE: test [ f ] [ f cons? ] unit-test [ f ] [ t cons? ] unit-test -[ t ] [ [ t | f ] cons? ] unit-test +[ t ] [ [[ t f ]] cons? ] unit-test -[ [ 1 | 2 ] ] [ 1 2 cons ] unit-test +[ [[ 1 2 ]] ] [ 1 2 cons ] unit-test [ [ 1 ] ] [ 1 f cons ] unit-test -[ [ 1 | 2 ] ] [ 2 1 swons ] unit-test +[ [[ 1 2 ]] ] [ 2 1 swons ] unit-test [ [ 1 ] ] [ f 1 swons ] unit-test [ [ [ [ ] ] ] ] [ [ ] unit unit ] unit-test -[ 1 ] [ [ 1 | 2 ] car ] unit-test -[ 2 ] [ [ 1 | 2 ] cdr ] unit-test +[ 1 ] [ [[ 1 2 ]] car ] unit-test +[ 2 ] [ [[ 1 2 ]] cdr ] unit-test -[ 1 2 ] [ [ 1 | 2 ] uncons ] unit-test +[ 1 2 ] [ [[ 1 2 ]] uncons ] unit-test [ 1 [ 2 ] ] [ [ 1 2 ] uncons ] unit-test -[ 1 2 ] [ [ 2 | 1 ] unswons ] unit-test +[ 1 2 ] [ [[ 2 1 ]] unswons ] unit-test [ [ 2 ] 1 ] [ [ 1 2 ] unswons ] unit-test [ [ 1 2 ] ] [ 1 2 2list ] unit-test [ [ 1 2 3 ] ] [ 1 2 3 3list ] unit-test -[ 1 3 ] [ [ 1 | 2 ] [ 3 | 4 ] 2car ] unit-test -[ 2 4 ] [ [ 1 | 2 ] [ 3 | 4 ] 2cdr ] unit-test -[ 1 3 2 4 ] [ [ 1 | 2 ] [ 3 | 4 ] 2uncons ] unit-test +[ 1 3 ] [ [[ 1 2 ]] [[ 3 4 ]] 2car ] unit-test +[ 2 4 ] [ [[ 1 2 ]] [[ 3 4 ]] 2cdr ] unit-test +[ 1 3 2 4 ] [ [[ 1 2 ]] [[ 3 4 ]] 2uncons ] unit-test diff --git a/library/test/lists/lists.factor b/library/test/lists/lists.factor index 232893f90c..212e537da5 100644 --- a/library/test/lists/lists.factor +++ b/library/test/lists/lists.factor @@ -10,7 +10,7 @@ USE: strings [ [ 1 ] ] [ [ 1 ] [ ] append ] unit-test [ [ 2 ] ] [ [ ] [ 2 ] append ] unit-test [ [ 1 2 3 4 ] ] [ [ 1 2 3 ] [ 4 ] append ] unit-test -[ [ 1 2 3 | 4 ] ] [ [ 1 2 3 ] 4 append ] unit-test +[ [[ 1 [[ 2 [[ 3 4 ]] ]] ]] ] [ [ 1 2 3 ] 4 append ] unit-test [ f ] [ 3 [ ] contains? ] unit-test [ f ] [ 3 [ 1 2 ] contains? ] unit-test @@ -19,11 +19,11 @@ USE: strings [ [ 3 ] ] [ [ 3 ] last* ] unit-test [ [ 3 ] ] [ [ 1 2 3 ] last* ] unit-test -[ [ 3 | 4 ] ] [ [ 1 2 3 | 4 ] last* ] unit-test +[ [[ 3 4 ]] ] [ [[ 1 [[ 2 [[ 3 4 ]] ]] ]] last* ] unit-test [ 3 ] [ [ 3 ] last ] unit-test [ 3 ] [ [ 1 2 3 ] last ] unit-test -[ 3 ] [ [ 1 2 3 | 4 ] last ] unit-test +[ 3 ] [ [[ 1 [[ 2 [[ 3 4 ]] ]] ]] last ] unit-test [ 0 ] [ [ ] length ] unit-test [ 3 ] [ [ 1 2 3 ] length ] unit-test @@ -31,7 +31,7 @@ USE: strings [ t ] [ f list? ] unit-test [ f ] [ t list? ] unit-test [ t ] [ [ 1 2 ] list? ] unit-test -[ f ] [ [ 1 | 2 ] list? ] unit-test +[ f ] [ [[ 1 2 ]] list? ] unit-test [ [ ] ] [ 1 [ ] remove ] unit-test [ [ ] ] [ 1 [ 1 ] remove ] unit-test @@ -49,7 +49,7 @@ USE: strings [ f ] [ 3 [ 1 [ 3 ] 2 ] tree-contains? not ] unit-test [ f ] [ 1 [ [ [ 1 ] ] 2 ] tree-contains? not ] unit-test [ f ] [ 2 [ 1 2 ] tree-contains? not ] unit-test -[ f ] [ 3 [ 1 2 | 3 ] tree-contains? not ] unit-test +[ f ] [ 3 [[ 1 [[ 2 3 ]] ]] tree-contains? not ] unit-test [ [ ] ] [ 0 count ] unit-test [ [ ] ] [ -10 count ] unit-test diff --git a/library/test/lists/namespaces.factor b/library/test/lists/namespaces.factor index e539095b9f..45708b0bd1 100644 --- a/library/test/lists/namespaces.factor +++ b/library/test/lists/namespaces.factor @@ -4,10 +4,10 @@ USE: namespaces USE: test [ [ 1 ] ] [ 1 f ] [ "x" set "x" cons@ "x" get ] test-word -[ [ 1 | 2 ] ] [ 1 2 ] [ "x" set "x" cons@ "x" get ] test-word +[ [[ 1 2 ]] ] [ 1 2 ] [ "x" set "x" cons@ "x" get ] test-word [ [ 1 2 ] ] [ 1 [ 2 ] ] [ "x" set "x" cons@ "x" get ] test-word -[ [ [ 2 | 3 ] [ 1 | 2 ] ] ] [ +[ [ [[ 2 3 ]] [[ 1 2 ]] ] ] [ "x" off 2 1 "x" [ acons ] change 3 2 "x" [ acons ] change "x" get ] unit-test diff --git a/library/test/parser.factor b/library/test/parser.factor index 182f4300f6..3c4fc60ea3 100644 --- a/library/test/parser.factor +++ b/library/test/parser.factor @@ -56,9 +56,9 @@ test-word ! Test improper lists -[ 2 ] [ "[ 1 | 2 ]" parse car cdr ] unit-test -[ "hello" ] [ "[ 1 | \"hello\" ]" parse car cdr ] unit-test -[ #{ 1 2 } ] [ "[ 1 | #{ 1 2 } ]" parse car cdr ] unit-test +[ 2 ] [ "[[ 1 2 ]]" parse car cdr ] unit-test +[ "hello" ] [ "[[ 1 \"hello\" ]]" parse car cdr ] unit-test +[ #{ 1 2 } ] [ "[[ 1 #{ 1 2 } ]]" parse car cdr ] unit-test ! Test EOL comments in multiline strings. [ [ "Hello" ] ] [ "#! This calls until-eol.\n\"Hello\"" parse ] unit-test diff --git a/library/test/styles.factor b/library/test/styles.factor index ff47fde10c..13a2d1ebaf 100644 --- a/library/test/styles.factor +++ b/library/test/styles.factor @@ -10,7 +10,7 @@ USE: test ] unit-test [ "Sans-Serif" ] [ [ - [ "font" | "Sans-Serif" ] + [[ "font" "Sans-Serif" ]] ] "fooquux" set-style "font" "fooquux" style assoc ] unit-test diff --git a/library/test/vectors.factor b/library/test/vectors.factor index 7a9a2e1a3b..909c0d7f8f 100644 --- a/library/test/vectors.factor +++ b/library/test/vectors.factor @@ -60,7 +60,7 @@ unit-test [ { 1 2 3 4 } { 5 6 7 8 } vector-zip [ uncons + ] vector-map ] unit-test -[ { [ 1 | 5 ] [ 2 | 6 ] [ 3 | 7 ] [ 4 | 8 ] } ] +[ { [[ 1 5 ]] [[ 2 6 ]] [[ 3 7 ]] [[ 4 8 ]] } ] [ { 1 2 3 4 } { 5 6 7 8 } vector-zip ] unit-test diff --git a/library/ui/console.factor b/library/ui/console.factor index 7a8540aee5..f2d2c3b3a9 100644 --- a/library/ui/console.factor +++ b/library/ui/console.factor @@ -228,13 +228,13 @@ PREDICATE: alien key-down-event SYMBOL: keymap {{ - [ [ "RETURN" ] | [ return-key ] ] - [ [ "BACKSPACE" ] | [ input-line get [ backspace ] bind ] ] - [ [ "LEFT" ] | [ input-line get [ left ] bind ] ] - [ [ "RIGHT" ] | [ input-line get [ right ] bind ] ] - [ [ "UP" ] | [ input-line get [ history-prev ] bind ] ] - [ [ "DOWN" ] | [ input-line get [ history-next ] bind ] ] - [ [ "CTRL" "k" ] | [ input-line get [ line-clear ] bind ] ] + [[ [ "RETURN" ] [ return-key ] ]] + [[ [ "BACKSPACE" ] [ input-line get [ backspace ] bind ] ]] + [[ [ "LEFT" ] [ input-line get [ left ] bind ] ]] + [[ [ "RIGHT" ] [ input-line get [ right ] bind ] ]] + [[ [ "UP" ] [ input-line get [ history-prev ] bind ] ]] + [[ [ "DOWN" ] [ input-line get [ history-next ] bind ] ]] + [[ [ "CTRL" "k" ] [ input-line get [ line-clear ] bind ] ]] }} keymap set M: key-down-event handle-event ( event -- ? ) diff --git a/library/win32/win32-errors.factor b/library/win32/win32-errors.factor index 5cb481271d..ae237be8ee 100644 --- a/library/win32/win32-errors.factor +++ b/library/win32/win32-errors.factor @@ -37,7 +37,7 @@ USE: alien USE: words : CONSTANT: CREATE - [ [ [ parsed ] each ] cons define-compound POSTPONE: parsing ] + [ [ [ swons ] each ] cons define-compound POSTPONE: parsing ] [ ] ; parsing CONSTANT: ERROR_SUCCESS 0 ; From 3eccfa495ed85255bfe26a49a19515a76f9bc9a3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 14 Jan 2005 17:01:48 +0000 Subject: [PATCH 020/122] simplifying the parser; #{ a b } is now #{ a b }# --- TODO.FACTOR.txt | 4 +- examples/dejong.factor | 2 +- examples/factoroids.factor | 4 +- examples/infix.factor | 2 +- examples/mandel.factor | 2 +- library/assoc.factor | 10 ++-- library/bootstrap/init.factor | 1 - library/combinators.factor | 44 ++++++++-------- library/cons.factor | 5 +- library/generic/predicate.factor | 15 ++---- library/lists.factor | 4 +- library/math/complex.factor | 4 +- library/math/constants.factor | 4 +- library/math/math-combinators.factor | 12 ++--- library/sdl/sdl-utils.factor | 2 +- library/syntax/parse-syntax.factor | 16 +++--- library/syntax/prettyprint.factor | 2 +- library/syntax/unparser.factor | 2 +- library/test/compiler/ifte.factor | 4 +- library/test/compiler/optimizer.factor | 18 +++---- library/test/hashtables.factor | 4 +- library/test/interpreter.factor | 4 +- library/test/lists/combinators.factor | 2 + library/test/lists/namespaces.factor | 4 +- library/test/math/complex.factor | 64 +++++++++++------------ library/test/math/irrational.factor | 2 +- library/test/math/math-combinators.factor | 20 +++---- library/test/parser.factor | 2 +- library/test/unparser.factor | 2 +- library/test/vectors.factor | 2 +- library/threads.factor | 12 ++--- library/tools/interpreter.factor | 2 +- library/vectors.factor | 10 +--- library/words.factor | 9 ++++ 34 files changed, 142 insertions(+), 154 deletions(-) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 86e5218c39..143a0a3f4a 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,9 +1,6 @@ + compiler: -- investigate why : foo t or ; doesn't partially evaluate -- investigate why ' doesn't infer - recursive? and tree-contains? should handle vectors -- type inference and recursion flaw - type inference fails with some assembler words; displaced, register and other predicates need to inherit from list not cons, and need stronger branch partial eval @@ -17,6 +14,7 @@ - make see work with union, builtin, predicate - doc comments of generics +- proper ordering for classes + ffi: diff --git a/examples/dejong.factor b/examples/dejong.factor index 2b890b92dd..ecb1967da9 100644 --- a/examples/dejong.factor +++ b/examples/dejong.factor @@ -39,7 +39,7 @@ SYMBOL: d : white ( -- rgb ) HEX: ffffffff ; -: pixel ( #{ x y } color -- ) +: pixel ( #{ x y }# color -- ) >r >r surface get r> >rect r> pixelColor ; : iterate-dejong ( x y -- x y ) diff --git a/examples/factoroids.factor b/examples/factoroids.factor index 0e09903a13..b462e9d59c 100644 --- a/examples/factoroids.factor +++ b/examples/factoroids.factor @@ -163,11 +163,11 @@ C: plasma ( actor dy -- plasma ) : player-fire ( -- ) #! Do nothing if player is dead. player-actor [ - #{ 0 -6 } player-shots cons@ + #{ 0 -6 }# player-shots cons@ ] when* ; : enemy-fire ( actor -- ) - #{ 0 5 } enemy-shots cons@ ; + #{ 0 5 }# enemy-shots cons@ ; ! Background of stars TRAITS: particle diff --git a/examples/infix.factor b/examples/infix.factor index bcdd97ef01..8deaa27314 100644 --- a/examples/infix.factor +++ b/examples/infix.factor @@ -14,7 +14,7 @@ SYMBOL: exprs DEFER: infix : >e exprs get vector-push ; : e> exprs get vector-pop ; -: e@ exprs get dup vector-empty? [ drop f ] [ vector-peek ] ifte ; +: e@ exprs get dup vector-length 0 = [ drop f ] [ vector-peek ] ifte ; : e, ( obj -- ) dup cons? [ [ e, ] each ] [ , ] ifte ; : end ( -- ) exprs get [ e, ] vector-each ; : >postfix ( op -- ) e@ word? [ e> e> -rot 3list ] when >e ; diff --git a/examples/mandel.factor b/examples/mandel.factor index 916b3cd1be..0e2ecf6888 100644 --- a/examples/mandel.factor +++ b/examples/mandel.factor @@ -72,7 +72,7 @@ SYMBOL: center height get 150000 zoom-fact get * / y-inc set nb-iter get max-color min cols set ; -: c ( #{ i j } -- c ) +: c ( #{ i j }# -- c ) >rect >r x-inc get * center get real x-inc get width get 2 / * - + >float r> diff --git a/library/assoc.factor b/library/assoc.factor index ed5001c8b3..6815f6bb6f 100644 --- a/library/assoc.factor +++ b/library/assoc.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2004 Slava Pestov. +! Copyright (C) 2004, 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -51,7 +51,7 @@ USE: kernel : remove-assoc ( key alist -- alist ) #! Remove all key/value pairs with this key. - [ dupd car = not ] subset nip ; + [ car = not ] subset-with ; : acons ( value key alist -- alist ) #! Adds the key/value pair to the alist. Existing pairs with @@ -83,11 +83,7 @@ USE: kernel : zip ( list list -- list ) #! Make a new list containing pairs of corresponding #! elements from the two given lists. - dup [ - 2uncons zip >r cons r> cons - ] [ - 2drop [ ] - ] ifte ; + dup [ 2uncons zip >r cons r> cons ] [ 2drop [ ] ] ifte ; : unzip ( assoc -- keys values ) #! Split an association list into two lists of keys and diff --git a/library/bootstrap/init.factor b/library/bootstrap/init.factor index bc0854d8aa..c9df175781 100644 --- a/library/bootstrap/init.factor +++ b/library/bootstrap/init.factor @@ -36,7 +36,6 @@ USE: words : boot ( -- ) #! Initialize an interpreter with the basic services. init-namespaces - init-threads init-stdio "HOME" os-env [ "." ] unless* "~" set init-search-path ; diff --git a/library/combinators.factor b/library/combinators.factor index 2c83e2a7c1..1620c6452a 100644 --- a/library/combinators.factor +++ b/library/combinators.factor @@ -56,6 +56,16 @@ IN: kernel #! condition and execute the 'false' quotation. pick [ drop call ] [ nip nip call ] ifte ; inline +: ?ifte ( default cond true false -- ) + #! If cond is true, drop default and apply true + #! quotation to cond. Otherwise, drop cond, and apply false + #! to default. + >r >r dup [ + nip r> r> drop call + ] [ + drop r> drop r> call + ] ifte ; inline + : unless ( cond quot -- ) #! Execute a quotation only when the condition is f. The #! condition is popped off the stack. @@ -72,6 +82,12 @@ IN: kernel #! value than it produces. over [ drop ] [ nip call ] ifte ; inline +: ?unless ( default cond false -- ) + #! If cond is true, drop default and leave cond on the + #! stack. Otherwise, drop default, and apply false + #! quotation to default. + >r dup [ nip r> drop ] [ drop r> call ] ifte ; inline + : when ( cond quot -- ) #! Execute a quotation only when the condition is not f. The #! condition is popped off the stack. @@ -89,31 +105,15 @@ IN: kernel #! value than it produces. dupd [ drop ] ifte ; inline -: forever ( quot -- ) - #! The code is evaluated in an infinite loop. Typically, a - #! continuation is used to escape the infinite loop. - #! - #! This combinator will not compile. - dup slip forever ; - -: ?ifte ( default cond true false -- ) - #! If cond is true, drop default and apply true - #! quotation to cond. Otherwise, drop cond, and apply false - #! to default. - >r >r dup [ - nip r> r> drop call - ] [ - drop r> drop r> call - ] ifte ; inline - : ?when ( default cond true -- ) #! If cond is true, drop default and apply true #! quotation to cond. Otherwise, drop cond, and leave #! default on the stack. >r dup [ nip r> call ] [ r> 2drop ] ifte ; inline -: ?unless ( default cond false -- ) - #! If cond is true, drop default and leave cond on the - #! stack. Otherwise, drop default, and apply false - #! quotation to default. - >r dup [ nip r> drop ] [ drop r> call ] ifte ; inline +: forever ( quot -- ) + #! The code is evaluated in an infinite loop. Typically, a + #! continuation is used to escape the infinite loop. + #! + #! This combinator will not compile. + dup slip forever ; diff --git a/library/cons.factor b/library/cons.factor index 21c5abd1d3..95243bad29 100644 --- a/library/cons.factor +++ b/library/cons.factor @@ -103,7 +103,7 @@ PREDICATE: general-list list ( list -- ? ) : with ( obj quot elt -- obj quot ) #! Utility word for each-with, map-with. - pick pick >r >r swap call r> r> ; + pick pick >r >r swap call r> r> ; inline : each-with ( obj list quot -- ) #! Push each element of a proper list in turn, and apply a @@ -121,3 +121,6 @@ PREDICATE: general-list list ( list -- ? ) ] [ drop ] ifte ; inline + +: subset-with ( obj list quot -- list ) + swap [ with rot ] subset nip nip ; inline diff --git a/library/generic/predicate.factor b/library/generic/predicate.factor index e6426b6cac..8f243576c7 100644 --- a/library/generic/predicate.factor +++ b/library/generic/predicate.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2004 Slava Pestov. +! Copyright (C) 2004, 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -74,22 +74,17 @@ predicate [ ] "class<" set-word-property : define-predicate ( class predicate definition -- ) - rot "superclass" word-property "predicate" word-property + pick "superclass" word-property "predicate" word-property [ \ dup , append, , [ drop f ] , \ ifte , ] make-list - define-compound ; + define-compound + predicate define-class ; : PREDICATE: ( -- class predicate definition ) #! Followed by a superclass name, then a class name. scan-word CREATE dup intern-symbol dup rot "superclass" set-word-property - dup predicate "metaclass" set-word-property dup predicate-word +! 2dup swap "predicate" set-word-property [ dupd unit "predicate" set-word-property ] keep [ define-predicate ] [ ] ; parsing - -PREDICATE: compound generic ( word -- ? ) - "combination" word-property ; - -PREDICATE: compound promise ( obj -- ? ) - "promise" word-property ; diff --git a/library/lists.factor b/library/lists.factor index 7cab567d56..c7e021ef82 100644 --- a/library/lists.factor +++ b/library/lists.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2003, 2004 Slava Pestov. +! Copyright (C) 2003, 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -132,7 +132,7 @@ DEFER: tree-contains? : remove ( obj list -- list ) #! Remove all occurrences of the object from the list. - [ dupd = not ] subset nip ; + [ = not ] subset-with ; : length ( list -- length ) 0 swap [ drop 1 + ] each ; diff --git a/library/math/complex.factor b/library/math/complex.factor index 5caf6b9254..fdc482fe03 100644 --- a/library/math/complex.factor +++ b/library/math/complex.factor @@ -35,11 +35,11 @@ USE: kernel-internals USE: math USE: math-internals -GENERIC: real ( #{ re im } -- re ) +GENERIC: real ( #{ re im }# -- re ) M: real real ; M: complex real 0 slot %real ; -GENERIC: imaginary ( #{ re im } -- im ) +GENERIC: imaginary ( #{ re im }# -- im ) M: real imaginary drop 0 ; M: complex imaginary 1 slot %real ; diff --git a/library/math/constants.factor b/library/math/constants.factor index 9b68d43ec6..cc73722929 100644 --- a/library/math/constants.factor +++ b/library/math/constants.factor @@ -28,8 +28,8 @@ IN: math USE: kernel -: i #{ 0 1 } ; inline -: -i #{ 0 -1 } ; inline +: i #{ 0 1 }# ; inline +: -i #{ 0 -1 }# ; inline : inf 1.0 0.0 / ; inline : -inf -1.0 0.0 / ; inline : e 2.7182818284590452354 ; inline diff --git a/library/math/math-combinators.factor b/library/math/math-combinators.factor index 5d61794463..ae666d2136 100644 --- a/library/math/math-combinators.factor +++ b/library/math/math-combinators.factor @@ -54,16 +54,16 @@ USE: kernel : fac ( n -- n! ) 1 swap [ 1 + * ] times* ; -: 2times-succ ( #{ a b } #{ c d } -- z ) - #! Lexicographically add #{ 0 1 } to a complex number. - #! If d + 1 == b, return #{ c+1 0 }. Otherwise, #{ c d+1 }. +: 2times-succ ( #{ a b }# #{ c d }# -- z ) + #! Lexicographically add #{ 0 1 }# to a complex number. + #! If d + 1 == b, return #{ c+1 0 }#. Otherwise, #{ c d+1 }#. 2dup imaginary 1 + swap imaginary = [ nip real 1 + ] [ nip >rect 1 + rect> ] ifte ; inline -: 2times<= ( #{ a b } #{ c d } -- ? ) +: 2times<= ( #{ a b }# #{ c d }# -- ? ) swap real swap real <= ; inline : (2times) ( limit n quot -- ) @@ -73,9 +73,9 @@ USE: kernel rot pick dupd 2times-succ pick 3slip (2times) ] ifte ; inline -: 2times* ( #{ w h } quot -- ) +: 2times* ( #{ w h }# quot -- ) #! Apply a quotation to each pair of complex numbers - #! #{ a b } such that a < w, b < h. + #! #{ a b }# such that a < w, b < h. 0 swap (2times) ; inline : (repeat) ( i n quot -- ) diff --git a/library/sdl/sdl-utils.factor b/library/sdl/sdl-utils.factor index 84ab7c2120..137d6deba1 100644 --- a/library/sdl/sdl-utils.factor +++ b/library/sdl/sdl-utils.factor @@ -68,7 +68,7 @@ SYMBOL: surface : clear-surface ( color -- ) >r surface get 0 0 width get height get r> boxColor ; -: pixel-step ( quot #{ x y } -- ) +: pixel-step ( quot #{ x y }# -- ) tuck >r call >r surface get r> r> >rect rot pixelColor ; inline diff --git a/library/syntax/parse-syntax.factor b/library/syntax/parse-syntax.factor index d20992b784..2853219c64 100644 --- a/library/syntax/parse-syntax.factor +++ b/library/syntax/parse-syntax.factor @@ -55,7 +55,7 @@ USE: unparser ! ( and #! then add "stack-effect" and "documentation" ! properties to the current word if it is set. -! Constants +! Booleans : t t swons ; parsing : f f swons ; parsing @@ -75,6 +75,10 @@ USE: unparser : {{ f ; parsing : }} alist>hash swons ; parsing +! Complex numbers +: #{ f ; parsing +: }# 2unlist swap rect> swons ; parsing + ! Do not execute parsing word : POSTPONE: ( -- ) scan-word swons ; parsing @@ -101,11 +105,13 @@ USE: unparser #! Create a word with no definition. Used for mutually #! recursive words. CREATE drop ; parsing + : FORGET: scan-word forget ; parsing : USE: #! Add vocabulary to search path. scan "use" cons@ ; parsing + : IN: #! Set vocabulary for new definitions. scan dup "use" cons@ "in" set ; parsing @@ -127,14 +133,6 @@ USE: unparser [ parse-string "col" get ] make-string swap "col" set swons ; parsing -: expect ( word -- ) - dup scan = [ drop ] [ "Expected " swap cat2 throw ] ifte ; - -: #{ - #! Complex literal - #{ real imaginary #} - scan str>number scan str>number rect> "}" expect swons ; - parsing - ! Comments : ( #! Stack comment. diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index 11fd9c179d..0af1918ff5 100644 --- a/library/syntax/prettyprint.factor +++ b/library/syntax/prettyprint.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2003, 2004 Slava Pestov. +! Copyright (C) 2003, 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: diff --git a/library/syntax/unparser.factor b/library/syntax/unparser.factor index e9337af832..f56641ec2c 100644 --- a/library/syntax/unparser.factor +++ b/library/syntax/unparser.factor @@ -98,7 +98,7 @@ M: complex unparse ( num -- str ) real unparse , " " , imaginary unparse , - " }" , + " }#" , ] make-string ; : ch>ascii-escape ( ch -- esc ) diff --git a/library/test/compiler/ifte.factor b/library/test/compiler/ifte.factor index be661b9c8b..8271d18dec 100644 --- a/library/test/compiler/ifte.factor +++ b/library/test/compiler/ifte.factor @@ -37,12 +37,12 @@ USE: math-internals : dead-code-rec t [ - #{ 3 2 } + #{ 3 2 }# ] [ dead-code-rec ] ifte ; compiled -[ #{ 3 2 } ] [ dead-code-rec ] unit-test +[ #{ 3 2 }# ] [ dead-code-rec ] unit-test : one-rec [ f one-rec ] [ "hi" ] ifte ; compiled diff --git a/library/test/compiler/optimizer.factor b/library/test/compiler/optimizer.factor index 7d592684d1..a7a746f661 100644 --- a/library/test/compiler/optimizer.factor +++ b/library/test/compiler/optimizer.factor @@ -9,12 +9,12 @@ USE: lists : foo 1 2 3 ; -! [ [ ] ] [ \ foo word-parameter dataflow kill-set ] unit-test -! -! [ [ [ + ] [ - ] ] ] [ [ 3 4 1 2 > [ + ] [ - ] ifte ] dataflow kill-set ] unit-test -! -! [ [ [ 1 ] [ 2 ] ] ] [ [ [ 1 ] [ 2 ] ifte ] dataflow kill-set ] unit-test -! -! [ [ [ 1 ] [ 2 ] ] ] [ [ t [ 1 ] [ 2 ] ifte ] dataflow kill-set ] unit-test -! -! [ [ t t f ] ] [ [ 1 2 ] [ 1 2 3 ] [ f ] map kill-mask ] unit-test +[ [ ] ] [ \ foo word-parameter dataflow kill-set ] unit-test + +[ [ [ + ] [ - ] ] ] [ [ 3 4 1 2 > [ + ] [ - ] ifte ] dataflow kill-set ] unit-test + +[ [ [ 1 ] [ 2 ] ] ] [ [ [ 1 ] [ 2 ] ifte ] dataflow kill-set ] unit-test + +[ [ [ 1 ] [ 2 ] ] ] [ [ [ 1 ] [ 2 ] ifte ] dataflow kill-set ] unit-test + +[ [ t t f ] ] [ [ 1 2 ] [ 1 2 3 ] [ f ] map kill-mask ] unit-test diff --git a/library/test/hashtables.factor b/library/test/hashtables.factor index c951e54669..cf7648aa5a 100644 --- a/library/test/hashtables.factor +++ b/library/test/hashtables.factor @@ -39,11 +39,11 @@ unit-test 16 "testhash" set -t #{ 2 3 } "testhash" get set-hash +t #{ 2 3 }# "testhash" get set-hash f 100 fac "testhash" get set-hash { } { [ { } ] } "testhash" get set-hash -[ t ] [ #{ 2 3 } "testhash" get hash ] unit-test +[ t ] [ #{ 2 3 }# "testhash" get hash ] unit-test [ f ] [ 100 fac "testhash" get hash* cdr ] unit-test [ { } ] [ { [ { } ] } vector-clone "testhash" get hash* cdr ] unit-test diff --git a/library/test/interpreter.factor b/library/test/interpreter.factor index 19fdcc01c2..52806eaf0f 100644 --- a/library/test/interpreter.factor +++ b/library/test/interpreter.factor @@ -44,8 +44,8 @@ USE: kernel [ "XYZ" "XuZ" = ] test-interpreter ] unit-test -[ { #{ 1 1.5 } { } #{ 1 1.5 } { } } ] [ - [ #{ 1 1.5 } { } 2dup ] test-interpreter +[ { #{ 1 1.5 }# { } #{ 1 1.5 }# { } } ] [ + [ #{ 1 1.5 }# { } 2dup ] test-interpreter ] unit-test [ { 4 } ] [ diff --git a/library/test/lists/combinators.factor b/library/test/lists/combinators.factor index 54e4650b3f..bbf0875e48 100644 --- a/library/test/lists/combinators.factor +++ b/library/test/lists/combinators.factor @@ -40,3 +40,5 @@ USE: strings [ f ] [ [ 1 2 3 ] [ 10 > ] some? ] unit-test [ [ 2 3 4 ] ] [ 1 [ 1 2 3 ] [ + ] map-with ] unit-test + +[ [ 3 ] ] [ 2 [ 1 2 3 ] [ < ] subset-with ] unit-test diff --git a/library/test/lists/namespaces.factor b/library/test/lists/namespaces.factor index 45708b0bd1..190e781399 100644 --- a/library/test/lists/namespaces.factor +++ b/library/test/lists/namespaces.factor @@ -29,9 +29,9 @@ USE: test "x" get ] unit-test -[ [ "xyz" #{ 3 2 } 1/5 [ { } ] ] ] [ +[ [ "xyz" #{ 3 2 }# 1/5 [ { } ] ] ] [ [ "xyz" , "xyz" unique, - #{ 3 2 } , #{ 3 2 } unique, + #{ 3 2 }# , #{ 3 2 }# unique, 1/5 , 1/5 unique, [ { } unique, ] make-list , ] make-list ] unit-test diff --git a/library/test/math/complex.factor b/library/test/math/complex.factor index 0ee0b8bcb7..4e084394d5 100644 --- a/library/test/math/complex.factor +++ b/library/test/math/complex.factor @@ -3,47 +3,47 @@ USE: kernel USE: math USE: test -[ f ] [ #{ 5 12.5 } 5 ] [ = ] test-word -[ t ] [ #{ 1.0 2.0 } #{ 1 2 } ] [ = ] test-word -[ f ] [ #{ 1.0 2.3 } #{ 1 2 } ] [ = ] test-word +[ f ] [ #{ 5 12.5 }# 5 ] [ = ] test-word +[ t ] [ #{ 1.0 2.0 }# #{ 1 2 }# ] [ = ] test-word +[ f ] [ #{ 1.0 2.3 }# #{ 1 2 }# ] [ = ] test-word -[ #{ 2 5 } ] [ 2 5 ] [ rect> ] test-word -[ 2 5 ] [ #{ 2 5 } ] [ >rect ] test-word -[ #{ 1/2 1 } ] [ 1/2 i ] [ + ] test-word -[ #{ 1/2 1 } ] [ i 1/2 ] [ + ] test-word -[ t ] [ #{ 11 64 } #{ 11 64 } ] [ = ] test-word -[ #{ 2 1 } ] [ 2 i ] [ + ] test-word -[ #{ 2 1 } ] [ i 2 ] [ + ] test-word -[ #{ 5 4 } ] [ #{ 2 2 } #{ 3 2 } ] [ + ] test-word -[ 5 ] [ #{ 2 2 } #{ 3 -2 } ] [ + ] test-word -[ #{ 1.0 1 } ] [ 1.0 i ] [ + ] test-word +[ #{ 2 5 }# ] [ 2 5 ] [ rect> ] test-word +[ 2 5 ] [ #{ 2 5 }# ] [ >rect ] test-word +[ #{ 1/2 1 }# ] [ 1/2 i ] [ + ] test-word +[ #{ 1/2 1 }# ] [ i 1/2 ] [ + ] test-word +[ t ] [ #{ 11 64 }# #{ 11 64 }# ] [ = ] test-word +[ #{ 2 1 }# ] [ 2 i ] [ + ] test-word +[ #{ 2 1 }# ] [ i 2 ] [ + ] test-word +[ #{ 5 4 }# ] [ #{ 2 2 }# #{ 3 2 }# ] [ + ] test-word +[ 5 ] [ #{ 2 2 }# #{ 3 -2 }# ] [ + ] test-word +[ #{ 1.0 1 }# ] [ 1.0 i ] [ + ] test-word -[ #{ 1/2 -1 } ] [ 1/2 i ] [ - ] test-word -[ #{ -1/2 1 } ] [ i 1/2 ] [ - ] test-word -[ #{ 1/3 1/4 } ] [ 1 3 / 1 2 / i * + 1 4 / i * ] [ - ] test-word -[ #{ -1/3 -1/4 } ] [ 1 4 / i * 1 3 / 1 2 / i * + ] [ - ] test-word -[ #{ 1/5 1/4 } ] [ #{ 3/5 1/2 } #{ 2/5 1/4 } ] [ - ] test-word -[ 4 ] [ #{ 5 10/3 } #{ 1 10/3 } ] [ - ] test-word -[ #{ 1.0 -1 } ] [ 1.0 i ] [ - ] test-word +[ #{ 1/2 -1 }# ] [ 1/2 i ] [ - ] test-word +[ #{ -1/2 1 }# ] [ i 1/2 ] [ - ] test-word +[ #{ 1/3 1/4 }# ] [ 1 3 / 1 2 / i * + 1 4 / i * ] [ - ] test-word +[ #{ -1/3 -1/4 }# ] [ 1 4 / i * 1 3 / 1 2 / i * + ] [ - ] test-word +[ #{ 1/5 1/4 }# ] [ #{ 3/5 1/2 }# #{ 2/5 1/4 }# ] [ - ] test-word +[ 4 ] [ #{ 5 10/3 }# #{ 1 10/3 }# ] [ - ] test-word +[ #{ 1.0 -1 }# ] [ 1.0 i ] [ - ] test-word -[ #{ 0 1 } ] [ i 1 ] [ * ] test-word -[ #{ 0 1 } ] [ 1 i ] [ * ] test-word -[ #{ 0 1.0 } ] [ 1.0 i ] [ * ] test-word +[ #{ 0 1 }# ] [ i 1 ] [ * ] test-word +[ #{ 0 1 }# ] [ 1 i ] [ * ] test-word +[ #{ 0 1.0 }# ] [ 1.0 i ] [ * ] test-word [ -1 ] [ i i ] [ * ] test-word -[ #{ 0 1 } ] [ 1 i ] [ * ] test-word -[ #{ 0 1 } ] [ i 1 ] [ * ] test-word -[ #{ 0 1/2 } ] [ 1/2 i ] [ * ] test-word -[ #{ 0 1/2 } ] [ i 1/2 ] [ * ] test-word -[ 2 ] [ #{ 1 1 } #{ 1 -1 } ] [ * ] test-word +[ #{ 0 1 }# ] [ 1 i ] [ * ] test-word +[ #{ 0 1 }# ] [ i 1 ] [ * ] test-word +[ #{ 0 1/2 }# ] [ 1/2 i ] [ * ] test-word +[ #{ 0 1/2 }# ] [ i 1/2 ] [ * ] test-word +[ 2 ] [ #{ 1 1 }# #{ 1 -1 }# ] [ * ] test-word [ 1 ] [ i -i ] [ * ] test-word [ -1 ] [ i -i ] [ / ] test-word -[ #{ 0 1 } ] [ 1 -i ] [ / ] test-word -[ t ] [ #{ 12 13 } #{ 13 14 } / #{ 13 14 } * #{ 12 13 } ] [ = ] test-word +[ #{ 0 1 }# ] [ 1 -i ] [ / ] test-word +[ t ] [ #{ 12 13 }# #{ 13 14 }# / #{ 13 14 }# * #{ 12 13 }# ] [ = ] test-word -[ #{ -3 4 } ] [ #{ 3 -4 } ] [ neg ] test-word +[ #{ -3 4 }# ] [ #{ 3 -4 }# ] [ neg ] test-word -[ 5 ] [ #{ 3 4 } abs ] unit-test +[ 5 ] [ #{ 3 4 }# abs ] unit-test [ 5 ] [ -5.0 abs ] unit-test ! Make sure arguments are sane diff --git a/library/test/math/irrational.factor b/library/test/math/irrational.factor index 41daa8b4c6..75985eabd7 100644 --- a/library/test/math/irrational.factor +++ b/library/test/math/irrational.factor @@ -9,7 +9,7 @@ USE: test [ 0.25 ] [ 2 -2 fpow ] unit-test [ 4.0 ] [ 16 sqrt ] unit-test -[ #{ 0 4.0 } ] [ -16 sqrt ] unit-test +[ #{ 0 4.0 }# ] [ -16 sqrt ] unit-test [ 4.0 ] [ 2 2 ^ ] unit-test [ 0.25 ] [ 2 -2 ^ ] unit-test diff --git a/library/test/math/math-combinators.factor b/library/test/math/math-combinators.factor index 6587bdc0bc..dec33d53d1 100644 --- a/library/test/math/math-combinators.factor +++ b/library/test/math/math-combinators.factor @@ -6,15 +6,15 @@ USE: test [ 0 1 2 3 4 ] [ 5 [ ] times* ] unit-test [ ] [ 0 [ ] times* ] unit-test -[ #{ 1 1 } ] [ #{ 2 3 } #{ 1 0 } 2times-succ ] unit-test -[ #{ 1 2 } ] [ #{ 2 3 } #{ 1 1 } 2times-succ ] unit-test -[ #{ 2 0 } ] [ #{ 3 3 } #{ 1 2 } 2times-succ ] unit-test -[ #{ 2 1 } ] [ #{ 3 3 } #{ 2 0 } 2times-succ ] unit-test -[ #{ 2 0 } ] [ #{ 2 2 } #{ 1 1 } 2times-succ ] unit-test +[ #{ 1 1 }# ] [ #{ 2 3 }# #{ 1 0 }# 2times-succ ] unit-test +[ #{ 1 2 }# ] [ #{ 2 3 }# #{ 1 1 }# 2times-succ ] unit-test +[ #{ 2 0 }# ] [ #{ 3 3 }# #{ 1 2 }# 2times-succ ] unit-test +[ #{ 2 1 }# ] [ #{ 3 3 }# #{ 2 0 }# 2times-succ ] unit-test +[ #{ 2 0 }# ] [ #{ 2 2 }# #{ 1 1 }# 2times-succ ] unit-test -[ #{ 0 0 } #{ 0 1 } #{ 1 0 } #{ 1 1 } ] -[ #{ 2 2 } [ ] 2times* ] unit-test +[ #{ 0 0 }# #{ 0 1 }# #{ 1 0 }# #{ 1 1 }# ] +[ #{ 2 2 }# [ ] 2times* ] unit-test -[ #{ 0 0 } #{ 0 1 } #{ 0 2 } #{ 1 0 } #{ 1 1 } #{ 1 2 } - #{ 2 0 } #{ 2 1 } #{ 2 2 } ] -[ #{ 3 3 } [ ] 2times* ] unit-test +[ #{ 0 0 }# #{ 0 1 }# #{ 0 2 }# #{ 1 0 }# #{ 1 1 }# #{ 1 2 }# + #{ 2 0 }# #{ 2 1 }# #{ 2 2 }# ] +[ #{ 3 3 }# [ ] 2times* ] unit-test diff --git a/library/test/parser.factor b/library/test/parser.factor index 3c4fc60ea3..39e0a81d8e 100644 --- a/library/test/parser.factor +++ b/library/test/parser.factor @@ -58,7 +58,7 @@ test-word [ 2 ] [ "[[ 1 2 ]]" parse car cdr ] unit-test [ "hello" ] [ "[[ 1 \"hello\" ]]" parse car cdr ] unit-test -[ #{ 1 2 } ] [ "[[ 1 #{ 1 2 } ]]" parse car cdr ] unit-test +[ #{ 1 2 }# ] [ "[[ 1 #{ 1 2 }# ]]" parse car cdr ] unit-test ! Test EOL comments in multiline strings. [ [ "Hello" ] ] [ "#! This calls until-eol.\n\"Hello\"" parse ] unit-test diff --git a/library/test/unparser.factor b/library/test/unparser.factor index e540ff9dfa..99c12fde8d 100644 --- a/library/test/unparser.factor +++ b/library/test/unparser.factor @@ -26,7 +26,7 @@ test-word [ "f" ] [ f unparse ] unit-test [ "t" ] [ t unparse ] unit-test [ "car" ] [ \ car unparse ] unit-test -[ "#{ 1/2 2/3 }" ] [ #{ 1/2 2/3 } unparse ] unit-test +[ "#{ 1/2 2/3 }#" ] [ #{ 1/2 2/3 }# unparse ] unit-test [ "1267650600228229401496703205376" ] [ 1 100 shift unparse ] unit-test [ ] [ { 1 2 3 } unparse drop ] unit-test diff --git a/library/test/vectors.factor b/library/test/vectors.factor index 909c0d7f8f..33904da9b5 100644 --- a/library/test/vectors.factor +++ b/library/test/vectors.factor @@ -11,7 +11,7 @@ USE: namespaces [ 3 ] [ { t f t } vector-length ] unit-test [ 3 { } vector-nth ] unit-test-fails -[ 3 #{ 1 2 } vector-nth ] unit-test-fails +[ 3 #{ 1 2 }# vector-nth ] unit-test-fails [ "hey" [ 1 2 ] set-vector-length ] unit-test-fails [ "hey" { 1 2 } set-vector-length ] unit-test-fails diff --git a/library/threads.factor b/library/threads.factor index c9d2471ea1..f0b61d50e5 100644 --- a/library/threads.factor +++ b/library/threads.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2004 Slava Pestov. +! Copyright (C) 2004, 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -35,14 +35,8 @@ USE: namespaces ! Core of the multitasker. Used by io-internals.factor and ! in-thread.factor. -: run-queue ( -- queue ) - 9 getenv ; - -: set-run-queue ( queue -- ) - 9 setenv ; - -: init-threads ( -- ) - f set-run-queue ; +: run-queue ( -- queue ) 9 getenv ; +: set-run-queue ( queue -- ) 9 setenv ; : next-thread ( -- quot ) #! Get and remove the next quotation from the run queue. diff --git a/library/tools/interpreter.factor b/library/tools/interpreter.factor index ae65b3039b..c6a8297c10 100644 --- a/library/tools/interpreter.factor +++ b/library/tools/interpreter.factor @@ -72,7 +72,7 @@ SYMBOL: meta-cf meta-cf get not ; : done? ( -- ? ) - done-cf? meta-r get vector-empty? and ; + done-cf? meta-r get vector-length 0 = and ; ! Callframe. : up ( -- ) diff --git a/library/vectors.factor b/library/vectors.factor index 25c87c0b49..dc8ec5be54 100644 --- a/library/vectors.factor +++ b/library/vectors.factor @@ -66,9 +66,6 @@ BUILTIN: vector 11 #! capacity. dup dup >r set-vector-length r> ; -: vector-empty? ( obj -- ? ) - vector-length 0 = ; - : vector-push ( obj vector -- ) #! Push a value on the end of a vector. dup vector-length swap set-vector-nth ; @@ -165,12 +162,9 @@ M: vector = ( obj vec -- ? ) ] ifte ] ifte ; -: ?vector-nth ( n vec -- obj/f ) - 2dup vector-length >= [ 2drop f ] [ vector-nth ] ifte ; - M: vector hashcode ( vec -- n ) - 0 swap 4 [ - over ?vector-nth hashcode rot bitxor swap + 0 swap dup vector-length 4 min [ + over vector-nth hashcode rot bitxor swap ] times* drop ; : vector-head ( n vector -- list ) diff --git a/library/words.factor b/library/words.factor index 3500233bc3..8530e879eb 100644 --- a/library/words.factor +++ b/library/words.factor @@ -73,6 +73,15 @@ PREDICATE: word primitive ( obj -- ? ) word-primitive 2 > ; PREDICATE: word symbol ( obj -- ? ) word-primitive 2 = ; PREDICATE: word undefined ( obj -- ? ) word-primitive 0 = ; +! These should really be somewhere in library/generic/, but +! during bootstrap, we cannot execute parsing words after they +! are defined by code loaded into the target image. +PREDICATE: compound generic ( word -- ? ) + "combination" word-property ; + +PREDICATE: compound promise ( obj -- ? ) + "promise" word-property ; + : define ( word primitive parameter -- ) pick set-word-parameter over set-word-primitive From 651bdb4709c1b0c989beecd44124d769b59cef2f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 14 Jan 2005 19:56:19 +0000 Subject: [PATCH 021/122] more parser cleanups; stack inference cleanups --- library/compiler/linearizer.factor | 13 ++-- library/compiler/optimizer.factor | 17 ++--- library/compiler/x86/generator.factor | 2 +- library/generic/predicate.factor | 2 +- library/inference/branches.factor | 6 +- library/inference/dataflow.factor | 3 - library/lists.factor | 16 +---- library/syntax/parse-syntax.factor | 19 +++-- library/syntax/parser.factor | 94 ++++++++----------------- library/test/compiler/linearizer.factor | 10 +++ library/test/dataflow.factor | 8 +-- library/test/parser.factor | 61 +++++++++------- library/test/test.factor | 1 + 13 files changed, 110 insertions(+), 142 deletions(-) create mode 100644 library/test/compiler/linearizer.factor diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor index 9d39ef8e52..2f67034160 100644 --- a/library/compiler/linearizer.factor +++ b/library/compiler/linearizer.factor @@ -34,6 +34,8 @@ USE: namespaces USE: words USE: strings USE: errors +USE: prettyprint +USE: kernel-internals ! The linear IR is close to assembly language. It also resembles ! Forth code in some sense. It exists so that pattern matching @@ -51,7 +53,7 @@ SYMBOL: #jump ( tail-call ) SYMBOL: #jump-label ( tail-call ) SYMBOL: #return-to ( push addr on C stack ) -! #dispatch is linearized as #dispatch followed by a #target +! dispatch is linearized as dispatch followed by a #target ! for each dispatch table entry. The linearizer ensures the ! correct number of #targets is emitted. SYMBOL: #target ( part of jump table ) @@ -127,8 +129,7 @@ SYMBOL: #target ( part of jump table ) : linearize-ifte ( param -- ) #! The parameter is a list of two lists, each one a dataflow #! IR. - uncons car - + + + wm.showDockableWindow("console"); + CompileBufferProcessor.compileWordsInBuffer(view,buffer, + FactorPlugin.getExternalInstance(), + wm.getDockableWindow("console")); + + diff --git a/examples/dejong.factor b/examples/dejong.factor index ecb1967da9..6d3313e1c8 100644 --- a/examples/dejong.factor +++ b/examples/dejong.factor @@ -4,7 +4,7 @@ ! ! ./f boot.image.le32 ! -libraries:sdl:name=libSDL.so -! -libraries:sdl-gfx:name=libSDL_gfx. +! -libraries:sdl-gfx:name=libSDL_gfx.so ! ! (But all on one line) ! @@ -36,9 +36,6 @@ SYMBOL: d : next-x ( x y -- x ) a get * sin swap b get * cos - ; : next-y ( x y -- y ) swap c get * sin swap d get * cos - ; -: white ( -- rgb ) - HEX: ffffffff ; - : pixel ( #{ x y }# color -- ) >r >r surface get r> >rect r> pixelColor ; @@ -52,20 +49,20 @@ SYMBOL: d : draw-dejong ( x0 y0 iterations -- ) [ iterate-dejong 2dup scale-dejong rect> white pixel - ] times 2drop ; + ] times 2drop ; compiled : dejong ( -- ) ! Fiddle with these four values! - 1.4 a set - -2.3 b set - 2.4 c set + 1.0 a set + -1.3 b set + 0.8 c set -2.1 d set - 640 480 32 SDL_HWSURFACE [ - [ 0 0 100000 draw-dejong ] with-surface + 1024 768 0 SDL_HWSURFACE [ + [ 0 0 200000 [ draw-dejong ] time ] with-surface event-loop SDL_Quit - ] with-screen ; compiled + ] with-screen ; -[ dejong ] time +dejong diff --git a/factor/FactorReader.java b/factor/FactorReader.java index db5f6e31a5..88be4656d9 100644 --- a/factor/FactorReader.java +++ b/factor/FactorReader.java @@ -241,10 +241,7 @@ public class FactorReader FactorWord word; if(define) - { word = lookup.define(getIn(),name); - definedWords = new Cons(word,definedWords); - } else { word = searchVocabulary(getUse(),name); @@ -283,6 +280,7 @@ public class FactorReader FactorWord w = intern((String)next,define); if(define && w != null) { + definedWords = new Cons(w,definedWords); w.line = line; w.col = col; w.file = scanner.getFileName(); diff --git a/factor/jedit/CompileBufferProcessor.java b/factor/jedit/CompileBufferProcessor.java new file mode 100644 index 0000000000..36f5f3d0d0 --- /dev/null +++ b/factor/jedit/CompileBufferProcessor.java @@ -0,0 +1,70 @@ +/* :folding=explicit:collapseFolds=1: */ + +/* + * $Id$ + * + * Copyright (C) 2005 Slava Pestov. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * 1. Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND + * FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; + * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, + * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR + * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF + * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + */ + +package factor.jedit; + +import console.Output; +import factor.*; +import java.io.IOException; +import java.util.*; +import org.gjt.sp.jedit.*; +import org.gjt.sp.util.*; + +public class CompileBufferProcessor extends FactorBufferProcessor +{ + //{{{ compileWordsInBuffer() method + public static void compileWordsInBuffer(View view, + Buffer buffer, + ExternalFactor factor, + Output output) throws Exception + { + String results = new CompileBufferProcessor( + buffer,factor).getResults(); + output.print(null,results); + } //}}} + + //{{{ CompileBufferProcessor constructor + public CompileBufferProcessor(Buffer buffer, ExternalFactor factor) + throws Exception + { + super(buffer,factor); + } //}}} + + //{{{ processWord() method + /** + * @return Code to process the word. + */ + public String processWord(FactorWord word) + { + StringBuffer expression = new StringBuffer(); + expression.append(FactorPlugin.factorWord(word)); + expression.append(" try-compile"); + return expression.toString(); + } //}}} +} diff --git a/factor/jedit/FactorBufferProcessor.java b/factor/jedit/FactorBufferProcessor.java index 9c85a9f82e..9333c6e976 100644 --- a/factor/jedit/FactorBufferProcessor.java +++ b/factor/jedit/FactorBufferProcessor.java @@ -30,8 +30,6 @@ package factor.jedit; import factor.*; -import java.io.IOException; -import java.util.*; import org.gjt.sp.jedit.Buffer; /** @@ -40,13 +38,13 @@ import org.gjt.sp.jedit.Buffer; */ public abstract class FactorBufferProcessor { - private LinkedHashMap results; + private String results; //{{{ FactorBufferProcessor constructor public FactorBufferProcessor(Buffer buffer, ExternalFactor factor) throws Exception { - results = new LinkedHashMap(); + StringBuffer buf = new StringBuffer(); Cons words = (Cons)buffer.getProperty( FactorSideKickParser.WORDS_PROPERTY); @@ -55,10 +53,14 @@ public abstract class FactorBufferProcessor { FactorWord word = (FactorWord)words.car; String expr = processWord(word); - System.err.println(expr); - results.put(word,factor.eval(expr)); + buf.append("! "); + buf.append(expr); + buf.append('\n'); + buf.append(factor.eval(expr)); words = words.next(); } + + results = buf.toString(); } //}}} /** @@ -66,14 +68,9 @@ public abstract class FactorBufferProcessor */ public abstract String processWord(FactorWord word); - //{{{ insertResults() method - public void insertResults(Buffer buffer, int offset) - throws Exception + //{{{ getResults() method + public String getResults() { - StringBuffer result = new StringBuffer(); - Iterator iter = results.values().iterator(); - while(iter.hasNext()) - result.append(iter.next()); - buffer.insert(offset,result.toString().trim()); + return results; } //}}} } diff --git a/factor/jedit/FactorPlugin.java b/factor/jedit/FactorPlugin.java index 97f2a49185..67c4791adc 100644 --- a/factor/jedit/FactorPlugin.java +++ b/factor/jedit/FactorPlugin.java @@ -154,7 +154,8 @@ public class FactorPlugin extends EditPlugin */ public static void stopExternalInstance() { - getFactorShell().closeStreams(); + if(getFactorShell() != null) + getFactorShell().closeStreams(); if(external != null) { diff --git a/factor/jedit/FactorPlugin.props b/factor/jedit/FactorPlugin.props index 19aa62262c..f23e301970 100644 --- a/factor/jedit/FactorPlugin.props +++ b/factor/jedit/FactorPlugin.props @@ -30,10 +30,11 @@ plugin.factor.jedit.FactorPlugin.menu=factor-listener \ factor-extract-word \ - \ factor-infer-effect \ - factor-compile \ - - \ factor-infer-effects \ - \ + factor-compile \ + factor-compile-all \ + - \ factor-restart factor-listener.label=Listener @@ -47,8 +48,9 @@ factor-edit-dialog.label=Edit word... factor-usages.label=Word usages at caret factor-extract-word.label=Extract word... factor-infer-effect.label=Infer word at caret -factor-compile.label=Compile word at caret factor-infer-effects.label=Infer all words in buffer +factor-compile.label=Compile word at caret +factor-compile-all.label=Compile all words in buffer factor-restart.label=Restart Factor # SideKick stuff diff --git a/factor/jedit/FactorSideKickParser.java b/factor/jedit/FactorSideKickParser.java index 8afd403d1a..95d54fcfb6 100644 --- a/factor/jedit/FactorSideKickParser.java +++ b/factor/jedit/FactorSideKickParser.java @@ -3,7 +3,7 @@ /* * $Id$ * - * Copyright (C) 2004 Slava Pestov. + * Copyright (C) 2004, 2005 Slava Pestov. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are met: diff --git a/factor/jedit/InferBufferProcessor.java b/factor/jedit/InferBufferProcessor.java index cfc266fcec..f1042ae5ce 100644 --- a/factor/jedit/InferBufferProcessor.java +++ b/factor/jedit/InferBufferProcessor.java @@ -46,7 +46,11 @@ public class InferBufferProcessor extends FactorBufferProcessor public static void createInferUnitTests(View view, final Buffer buffer, final ExternalFactor factor) + throws Exception { + final String results = new InferBufferProcessor(buffer,factor) + .getResults(); + final Buffer newBuffer = jEdit.newFile(view); VFSManager.runInAWTThread(new Runnable() { @@ -55,8 +59,7 @@ public class InferBufferProcessor extends FactorBufferProcessor newBuffer.setMode("factor"); try { - new InferBufferProcessor(buffer,factor) - .insertResults(newBuffer,0); + newBuffer.insert(0,results); } catch(Exception e) { diff --git a/library/sdl/sdl-ttf.factor b/library/sdl/sdl-ttf.factor index 068317171b..3961b0b0d8 100644 --- a/library/sdl/sdl-ttf.factor +++ b/library/sdl/sdl-ttf.factor @@ -1,4 +1,4 @@ -! :folding=indent:collapseFolds=1:sidekick.parser=none: +! :folding=indent:collapseFolds=1: ! $Id$ ! @@ -78,8 +78,8 @@ USE: alien : TTF_FontFaceStyleName ( font -- n ) "char*" "sdl-ttf" "TTF_FontFaceStyleName" [ "void*" ] alien-invoke ; -: TTF_RenderText_Solid ( font text fg bg -- surface ) - "surface*" "sdl-ttf" "TTF_RenderText_Solid" [ "void*" "char*" "int" "int" ] alien-invoke ; +: TTF_RenderText_Solid ( font text fg -- surface ) + "surface*" "sdl-ttf" "TTF_RenderText_Solid" [ "void*" "char*" "int" ] alien-invoke ; : TTF_RenderGlyph_Shaded ( font text fg bg -- surface ) "surface*" "sdl-ttf" "TTF_RenderGlyph_Shaded" [ "void*" "ushort" "int" "int" ] alien-invoke ; diff --git a/library/tools/jedit.factor b/library/tools/jedit.factor index 2e5603075e..39ee372a61 100644 --- a/library/tools/jedit.factor +++ b/library/tools/jedit.factor @@ -83,9 +83,6 @@ USE: words "newPlainView" off ] extend make-jedit-request send-jedit-request ; -: resource-path ( -- path ) - global [ "resource-path" get ] bind [ "." ] unless* ; - : word-file ( path -- dir file ) dup [ "resource:/" ?str-head [ From 406a989bab174b7182225be233507303ca95a57b Mon Sep 17 00:00:00 2001 From: Mackenzie Straight Date: Sun, 23 Jan 2005 04:40:26 +0000 Subject: [PATCH 030/122] add sdl-ttf library for Windows --- library/bootstrap/init-stage2.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/library/bootstrap/init-stage2.factor b/library/bootstrap/init-stage2.factor index 0bd93a7895..edf3b32046 100644 --- a/library/bootstrap/init-stage2.factor +++ b/library/bootstrap/init-stage2.factor @@ -89,6 +89,7 @@ os "win32" = [ "libc" "msvcrt.dll" "cdecl" add-library "sdl" "SDL.dll" "cdecl" add-library "sdl-gfx" "SDL_gfx.dll" "cdecl" add-library + "sdl-ttf" "SDL_ttf.dll" "cdecl" add-library ! FIXME: KLUDGE to get FFI-based IO going in Windows. "/library/bootstrap/win32-io.factor" run-resource ] when From 73d505339a44e39ed448f1180230aa7cabdb77fa Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Jan 2005 21:47:28 +0000 Subject: [PATCH 031/122] removed times*, use repeat instead --- examples/dejong.factor | 2 +- examples/factoroids.factor | 10 +-- examples/mandel.factor | 12 +-- library/bootstrap/boot-stage2.factor | 1 - library/bootstrap/boot.factor | 1 - library/bootstrap/image.factor | 4 +- library/compiler/alien.factor | 12 ++- library/generic/complement.factor | 7 +- library/generic/object.factor | 4 +- library/hashtables.factor | 19 ----- library/inference/types.factor | 11 +-- library/lists.factor | 13 ++-- library/math/math-combinators.factor | 91 ----------------------- library/math/math.factor | 16 ++++ library/sdl/sdl-ttf.factor | 5 +- library/sdl/sdl-utils.factor | 26 ++++--- library/sdl/sdl-video.factor | 34 +++++++-- library/strings.factor | 18 +++-- library/syntax/prettyprint.factor | 2 +- library/test/benchmark/empty-loop.factor | 2 +- library/test/benchmark/fac.factor | 14 +++- library/test/benchmark/hashtables.factor | 4 +- library/test/benchmark/vectors.factor | 4 +- library/test/generic.factor | 10 +++ library/test/hashtables.factor | 6 +- library/test/math/math-combinators.factor | 21 ++---- library/test/vectors.factor | 8 -- library/ui/console.factor | 12 +-- library/vectors.factor | 53 ++++++------- 29 files changed, 182 insertions(+), 240 deletions(-) delete mode 100644 library/math/math-combinators.factor diff --git a/examples/dejong.factor b/examples/dejong.factor index 6d3313e1c8..03c0f58f17 100644 --- a/examples/dejong.factor +++ b/examples/dejong.factor @@ -48,7 +48,7 @@ SYMBOL: d : draw-dejong ( x0 y0 iterations -- ) [ - iterate-dejong 2dup scale-dejong rect> white pixel + iterate-dejong 2dup scale-dejong rect> white rgb pixel ] times 2drop ; compiled : dejong ( -- ) diff --git a/examples/factoroids.factor b/examples/factoroids.factor index b462e9d59c..4c3e908a7c 100644 --- a/examples/factoroids.factor +++ b/examples/factoroids.factor @@ -129,7 +129,7 @@ M: ship tick ( actor -- ? ) dup [ move ] bind active? ; C: ship ( -- ship ) [ width get 2 /i height get 50 - rect> position set - white color set + white rgb color set 10 radius set 0 velocity set active on @@ -154,7 +154,7 @@ C: plasma ( actor dy -- plasma ) [ velocity set actor-xy - blue color set + blue rgb color set 10 len set 5 radius set active on @@ -195,7 +195,7 @@ SYMBOL: stars : random-y 0 height get random-int ; : random-position random-x random-y rect> ; : random-byte 0 255 random-int ; -: random-color random-byte random-byte random-byte 255 rgba ; +: random-color random-byte random-byte random-byte rgb ; : random-velocity 0 10 20 random-int 10 /f rect> ; : random-star ( -- star ) @@ -254,7 +254,7 @@ C: enemy ; : spawn-enemy ( -- ) [ random-x 10 rect> position set - red color set + red rgb color set 0 wiggle-x set 0 velocity set 10 radius set @@ -316,7 +316,7 @@ SYMBOL: event : render ( -- ) #! Draw the scene. - [ black clear-surface draw-stars draw-actors ] with-surface ; + [ black rgb clear-surface draw-stars draw-actors ] with-surface ; : advance ( -- ) #! Advance game state by one frame. diff --git a/examples/mandel.factor b/examples/mandel.factor index 0e2ecf6888..a4384c2878 100644 --- a/examples/mandel.factor +++ b/examples/mandel.factor @@ -32,7 +32,7 @@ USE: test : scale 255 * >fixnum ; -: scale-rgba ( r g b -- n ) +: scale-rgb ( r g b -- n ) scale swap scale 8 shift bitor swap scale 16 shift bitor @@ -44,9 +44,9 @@ USE: test : ( nb-cols -- map ) [ dup [ - 360 * over 1 + / 360 / sat val - hsv>rgb 1.0 scale-rgba , - ] times* + dup 360 * over 1 + / 360 / sat val + hsv>rgb 1.0 scale-rgb , + ] repeat ] make-list list>vector nip ; : absq >rect swap sq swap sq + ; inline @@ -73,14 +73,14 @@ SYMBOL: center nb-iter get max-color min cols set ; : c ( #{ i j }# -- c ) - >rect >r + >r x-inc get * center get real x-inc get width get 2 / * - + >float r> y-inc get * center get imaginary y-inc get height get 2 / * - + >float rect> ; : render ( -- ) - width get height get [ + [ c 0 nb-iter get iter dup 0 = [ drop 0 ] [ diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index dd4addbadd..2456ed93f7 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -57,7 +57,6 @@ USE: namespaces "/library/math/float.factor" "/library/math/complex.factor" "/library/words.factor" - "/library/math/math-combinators.factor" "/library/lists.factor" "/library/vectors.factor" "/library/strings.factor" diff --git a/library/bootstrap/boot.factor b/library/bootstrap/boot.factor index 6b7e0dd495..49a272f6c5 100644 --- a/library/bootstrap/boot.factor +++ b/library/bootstrap/boot.factor @@ -51,7 +51,6 @@ USE: hashtables "/library/math/float.factor" parse-resource append, "/library/math/complex.factor" parse-resource append, "/library/words.factor" parse-resource append, - "/library/math/math-combinators.factor" parse-resource append, "/library/lists.factor" parse-resource append, "/library/vectors.factor" parse-resource append, "/library/strings.factor" parse-resource append, diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index 820c63283e..9b4e47857b 100644 --- a/library/bootstrap/image.factor +++ b/library/bootstrap/image.factor @@ -285,8 +285,8 @@ M: vector ' ( vector -- pointer ) ! Now make a rehashing boot quotation dup hash>alist [ >r dup vector-length [ - f swap pick set-vector-nth - ] times* r> + [ f swap pick set-vector-nth ] keep + ] repeat r> [ unswons rot set-hash ] each-with ] cons cons boot-quot [ append ] change ; diff --git a/library/compiler/alien.factor b/library/compiler/alien.factor index 7b99e0343e..056ae65cc7 100644 --- a/library/compiler/alien.factor +++ b/library/compiler/alien.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2004 Slava Pestov. +! Copyright (C) 2004, 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -40,6 +40,7 @@ USE: parser USE: words USE: hashtables USE: strings +USE: unparser ! Command line parameters specify libraries to load. ! @@ -68,6 +69,15 @@ M: alien = ( obj obj -- ? ) 2drop f ] ifte ; +M: alien unparse ( obj -- str ) + [ + "#<" , + dup local-alien? "local-alien" "alien" ? , + " @ " , + alien-address unparse , + ">" , + ] make-string ; + : library ( name -- object ) dup [ "libraries" get hash ] when ; diff --git a/library/generic/complement.factor b/library/generic/complement.factor index e0014b1666..26bd8e3f62 100644 --- a/library/generic/complement.factor +++ b/library/generic/complement.factor @@ -48,7 +48,12 @@ complement [ complement [ ( generic vtable definition class -- ) - drop num-types [ >r 3dup r> add-method ] times* 3drop + drop num-types [ + [ + >r 3dup r> builtin-type + dup [ add-method ] [ 2drop 2drop ] ifte + ] keep + ] repeat 3drop ] "add-method" set-word-property complement 90 "priority" set-word-property diff --git a/library/generic/object.factor b/library/generic/object.factor index 61e5941f24..7802599697 100644 --- a/library/generic/object.factor +++ b/library/generic/object.factor @@ -47,8 +47,8 @@ object [ object [ ( generic vtable definition class -- ) drop over vector-length [ - pick pick -rot set-vector-nth - ] times* 3drop + 3dup rot set-vector-nth + ] repeat 3drop ] "add-method" set-word-property object [ drop t ] "predicate" set-word-property diff --git a/library/hashtables.factor b/library/hashtables.factor index e910815fc7..33e65a94cf 100644 --- a/library/hashtables.factor +++ b/library/hashtables.factor @@ -105,22 +105,3 @@ PREDICATE: vector hashtable ( obj -- ? ) : alist>hash ( alist -- hash ) 37 swap [ unswons pick set-hash ] each ; - -! In case I break hashing: - -! : hash* ( key table -- value ) -! hash>alist assoc* ; -! -! : set-hash ( value key table -- ) -! dup vector-length [ -! ( value key table index ) -! >r 3dup r> -! ( value key table value key table index ) -! [ -! swap vector-nth -! ( value key table value key alist ) -! set-assoc -! ] keep -! ( value key table new-assoc index ) -! pick set-vector-nth -! ] times* 3drop ; diff --git a/library/inference/types.factor b/library/inference/types.factor index e962b5ed90..5e6b19d114 100644 --- a/library/inference/types.factor +++ b/library/inference/types.factor @@ -74,15 +74,8 @@ USE: prettyprint ] "infer" set-word-property : type-value-map ( value -- ) - [ - num-types [ - dup builtin-type dup [ - pick swons cons , - ] [ - 2drop - ] ifte - ] times* - ] make-list nip ; + num-types [ dup builtin-type pick swons cons ] project + [ cdr cdr ] subset nip ; \ type [ [ object ] ensure-d diff --git a/library/lists.factor b/library/lists.factor index cfe95b7db1..20265abfe2 100644 --- a/library/lists.factor +++ b/library/lists.factor @@ -161,15 +161,14 @@ M: cons = ( obj cons -- ? ) M: cons hashcode ( cons -- hash ) car hashcode ; -: project ( n quot -- list ) - #! Execute the quotation n times, passing the loop counter - #! the quotation as it ranges from 0..n-1. Collect results - #! in a new list. - [ ] rot [ -rot over >r >r call r> cons r> swap ] times* - nip reverse ; inline +: (count) ( i n -- list ) + 2dup >= [ 2drop [ ] ] [ >r dup 1 + r> (count) cons ] ifte ; : count ( n -- [ 0 ... n-1 ] ) - [ ] project ; + 0 swap (count) ; + +: project ( n quot -- list ) + >r count r> map ; inline : head ( list n -- list ) #! Return the first n elements of the list. diff --git a/library/math/math-combinators.factor b/library/math/math-combinators.factor deleted file mode 100644 index ae666d2136..0000000000 --- a/library/math/math-combinators.factor +++ /dev/null @@ -1,91 +0,0 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2003, 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -IN: math -USE: kernel - -: times ( n quot -- ) - #! Evaluate a quotation n times. - #! - #! In order to compile, the code must produce as many values - #! as it consumes. - tuck >r dup 0 <= [ r> 3drop ] [ 1 - slip r> times ] ifte ; - inline - -: (times) ( limit n quot -- ) - pick pick <= [ - 3drop - ] [ - rot pick 1 + pick 3slip (times) - ] ifte ; inline - -: times* ( n quot -- ) - #! Evaluate a quotation n times, pushing the index at each - #! iteration. The index ranges from 0 to n-1. - #! - #! In order to compile, the code must consume one more value - #! than it produces. - 0 swap (times) ; inline - -: fac ( n -- n! ) - 1 swap [ 1 + * ] times* ; - -: 2times-succ ( #{ a b }# #{ c d }# -- z ) - #! Lexicographically add #{ 0 1 }# to a complex number. - #! If d + 1 == b, return #{ c+1 0 }#. Otherwise, #{ c d+1 }#. - 2dup imaginary 1 + swap imaginary = [ - nip real 1 + - ] [ - nip >rect 1 + rect> - ] ifte ; inline - -: 2times<= ( #{ a b }# #{ c d }# -- ? ) - swap real swap real <= ; inline - -: (2times) ( limit n quot -- ) - pick pick 2times<= [ - 3drop - ] [ - rot pick dupd 2times-succ pick 3slip (2times) - ] ifte ; inline - -: 2times* ( #{ w h }# quot -- ) - #! Apply a quotation to each pair of complex numbers - #! #{ a b }# such that a < w, b < h. - 0 swap (2times) ; inline - -: (repeat) ( i n quot -- ) - pick pick >= [ - 3drop - ] [ - [ swap >r call 1 + r> ] keep (repeat) - ] ifte ; - -: repeat ( n quot -- ) - #! Execute a quotation n times. The loop counter is kept on - #! the stack, and ranges from 0 to n-1. - 0 -rot (repeat) ; diff --git a/library/math/math.factor b/library/math/math.factor index 6e733352b2..69abeb22fb 100644 --- a/library/math/math.factor +++ b/library/math/math.factor @@ -114,3 +114,19 @@ M: real abs dup 0 < [ neg ] when ; : align ( offset width -- offset ) 2dup mod dup 0 number= [ 2drop ] [ - + ] ifte ; + +: (repeat) ( i n quot -- ) + pick pick >= [ + 3drop + ] [ + [ swap >r call 1 + r> ] keep (repeat) + ] ifte ; inline + +: repeat ( n quot -- ) + #! Execute a quotation n times. The loop counter is kept on + #! the stack, and ranges from 0 to n-1. + 0 -rot (repeat) ; inline + +: times ( n quot -- ) + #! Evaluate a quotation n times. + swap [ >r dup slip r> ] repeat drop ; inline diff --git a/library/sdl/sdl-ttf.factor b/library/sdl/sdl-ttf.factor index 3961b0b0d8..a84417bb81 100644 --- a/library/sdl/sdl-ttf.factor +++ b/library/sdl/sdl-ttf.factor @@ -81,11 +81,14 @@ USE: alien : TTF_RenderText_Solid ( font text fg -- surface ) "surface*" "sdl-ttf" "TTF_RenderText_Solid" [ "void*" "char*" "int" ] alien-invoke ; +: TTF_RenderText_Shaded ( font text fg bg -- surface ) + "surface*" "sdl-ttf" "TTF_RenderText_Shaded" [ "void*" "char*" "int" "int" ] alien-invoke ; + : TTF_RenderGlyph_Shaded ( font text fg bg -- surface ) "surface*" "sdl-ttf" "TTF_RenderGlyph_Shaded" [ "void*" "ushort" "int" "int" ] alien-invoke ; : TTF_RenderText_Blended ( font text fg -- surface ) - "surface*" "sdl-ttf" "TTF_RenderText_Blended" [ "void*" "ushort" "int" "int" ] alien-invoke ; + "surface*" "sdl-ttf" "TTF_RenderText_Blended" [ "void*" "ushort" "int" ] alien-invoke ; : TTF_RenderGlyph_Blended ( font text fg -- surface ) "surface*" "sdl-ttf" "TTF_RenderGlyph_Blended" [ "void*" "ushort" "int" ] alien-invoke ; diff --git a/library/sdl/sdl-utils.factor b/library/sdl/sdl-utils.factor index 137d6deba1..2e7f1b406c 100644 --- a/library/sdl/sdl-utils.factor +++ b/library/sdl/sdl-utils.factor @@ -54,26 +54,28 @@ SYMBOL: surface #! Set up SDL graphics and call the quotation. [ >r init-screen r> call SDL_Quit ] with-scope ; inline -: rgba ( r g b a -- n ) +: rgb ( r g b a -- n ) + 255 swap 8 shift bitor swap 16 shift bitor swap 24 shift bitor ; -: black 0 0 0 255 rgba ; -: white 255 255 255 255 rgba ; -: red 255 0 0 255 rgba ; -: green 0 255 0 255 rgba ; -: blue 0 0 255 255 rgba ; +: black 0 0 0 ; +: white 255 255 255 ; +: red 255 0 0 ; +: green 0 255 0 ; +: blue 0 0 255 ; : clear-surface ( color -- ) >r surface get 0 0 width get height get r> boxColor ; -: pixel-step ( quot #{ x y }# -- ) - tuck >r call >r surface get r> r> >rect rot pixelColor ; - inline - -: with-pixels ( w h quot -- ) - -rot rect> [ over >r pixel-step r> ] 2times* drop ; inline +: with-pixels ( quot -- ) + width get [ + height get [ + [ rot dup slip swap surface get swap ] 2keep + [ rot pixelColor ] 2keep + ] repeat + ] repeat drop ; inline : with-surface ( quot -- ) #! Execute a quotation, locking the current surface if it diff --git a/library/sdl/sdl-video.factor b/library/sdl/sdl-video.factor index 7f7ea3d696..a7c1722484 100644 --- a/library/sdl/sdl-video.factor +++ b/library/sdl/sdl-video.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2004 Slava Pestov. +! Copyright (C) 2004, 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -60,6 +60,13 @@ BEGIN-STRUCT: rect FIELD: ushort h END-STRUCT +BEGIN-STRUCT: color + FIELD: uchar r + FIELD: uchar g + FIELD: uchar b + FIELD: uchar unused +END-STRUCT + BEGIN-STRUCT: format FIELD: void* palette FIELD: uchar BitsPerPixel @@ -148,10 +155,9 @@ END-STRUCT ! SDL_SetGamma: float types -: SDL_FillRect ( surface rect color -- n ) - #! If rect is null, fills entire surface. - "bool" "sdl" "SDL_FillRect" - [ "surface*" "rect*" "uint" ] alien-invoke ; +: SDL_MapRGB ( surface r g b -- rgb ) + "uint" "sdl" "SDL_MapRGB" + [ "surface*" "uchar" "uchar" "uchar" ] alien-invoke ; : SDL_LockSurface ( surface -- ? ) "bool" "sdl" "SDL_LockSurface" [ "surface*" ] alien-invoke ; @@ -159,9 +165,21 @@ END-STRUCT : SDL_UnlockSurface ( surface -- ) "void" "sdl" "SDL_UnlockSurface" [ "surface*" ] alien-invoke ; -: SDL_MapRGB ( surface r g b -- rgb ) - "uint" "sdl" "SDL_MapRGB" - [ "surface*" "uchar" "uchar" "uchar" ] alien-invoke ; +: SDL_FreeSurface ( surface -- ) + "void" "sdl" "SDL_FreeSurface" [ "surface*" ] alien-invoke ; + +: SDL_UpperBlit ( src srcrect dst dstrect -- ) + #! The blit function should not be called on a locked + #! surface. + "int" "sdl" "SDL_UpperBlit" [ + "surface*" "rect*" + "surface*" "rect*" + ] alien-invoke ; + +: SDL_FillRect ( surface rect color -- n ) + #! If rect is null, fills entire surface. + "bool" "sdl" "SDL_FillRect" + [ "surface*" "rect*" "uint" ] alien-invoke ; : SDL_WM_SetCaption ( title icon -- ) "void" "sdl" "SDL_WM_SetCaption" diff --git a/library/strings.factor b/library/strings.factor index 42e82b7ee4..c663c27b1f 100644 --- a/library/strings.factor +++ b/library/strings.factor @@ -134,12 +134,20 @@ UNION: text string integer ; rot str-head swap ] ifte ; -: str-each ( str [ code ] -- ) - #! Execute the code, with each character of the string +: (str>list) ( i str -- list ) + 2dup str-length >= [ + 2drop [ ] + ] [ + 2dup str-nth >r >r 1 + r> (str>list) r> swons + ] ifte ; + +: str>list ( str -- list ) + 0 swap (str>list) ; + +: str-each ( str quot -- ) + #! Execute the quotation with each character of the string #! pushed onto the stack. - over str-length [ - -rot 2dup >r >r >r str-nth r> call r> r> - ] times* 2drop ; inline + >r str>list r> each ; inline PREDICATE: integer blank " \t\n\r" str-contains? ; PREDICATE: integer letter CHAR: a CHAR: z between? ; diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index 0af1918ff5..15fefa4794 100644 --- a/library/syntax/prettyprint.factor +++ b/library/syntax/prettyprint.factor @@ -186,7 +186,7 @@ M: hashtable prettyprint* ( indent hashtable -- indent ) : {.} ( vector -- ) #! Unparse each element on its own line. - stack>list [ . ] each ; + vector>list reverse [ . ] each ; : .s datastack {.} ; : .r callstack {.} ; diff --git a/library/test/benchmark/empty-loop.factor b/library/test/benchmark/empty-loop.factor index c9eb24ed22..43875a217a 100644 --- a/library/test/benchmark/empty-loop.factor +++ b/library/test/benchmark/empty-loop.factor @@ -8,7 +8,7 @@ USE: test [ ] times ; compiled : empty-loop-2 ( n -- ) - [ drop ] times* ; compiled + [ ] repeat ; compiled [ ] [ 5000000 empty-loop-1 ] unit-test [ ] [ 5000000 empty-loop-2 ] unit-test diff --git a/library/test/benchmark/fac.factor b/library/test/benchmark/fac.factor index 41dfabc6ee..5beeec8ff5 100644 --- a/library/test/benchmark/fac.factor +++ b/library/test/benchmark/fac.factor @@ -4,12 +4,22 @@ USE: test USE: compiler USE: kernel +: (fac) ( n! i -- n! ) + dup 0 = [ + drop + ] [ + [ * ] keep 1 - (fac) + ] ifte ; + +: fac ( n -- n! ) + 1 swap (fac) ; + : small-fac-benchmark #! This tests fixnum math. - 1 swap [ 10 fac 10 [ 1 + / ] times* max ] times ; compiled + 1 swap [ 10 fac 10 [ [ 1 + / ] keep ] repeat max ] times ; compiled : big-fac-benchmark - 10000 fac 10000 [ 1 + / ] times* ; compiled + 10000 fac 10000 [ [ 1 + / ] keep ] repeat ; compiled [ 1 ] [ big-fac-benchmark ] unit-test diff --git a/library/test/benchmark/hashtables.factor b/library/test/benchmark/hashtables.factor index 528e28cd1b..087cfb95b8 100644 --- a/library/test/benchmark/hashtables.factor +++ b/library/test/benchmark/hashtables.factor @@ -9,10 +9,10 @@ USE: compiler ! http://inferno.bell-labs.com/cm/cs/who/bwk/interps/pap.html : store-hash ( hashtable n -- ) - [ dup >hex swap pick set-hash ] times* drop ; compiled + [ [ dup >hex swap pick set-hash ] keep ] repeat drop ; compiled : lookup-hash ( hashtable n -- ) - [ unparse over hash drop ] times* drop ; compiled + [ [ unparse over hash drop ] keep ] repeat drop ; compiled : hashtable-benchmark ( n -- ) 60000 swap 2dup store-hash lookup-hash ; compiled diff --git a/library/test/benchmark/vectors.factor b/library/test/benchmark/vectors.factor index 80de85a7ae..8d6a767991 100644 --- a/library/test/benchmark/vectors.factor +++ b/library/test/benchmark/vectors.factor @@ -7,7 +7,7 @@ USE: test ! http://inferno.bell-labs.com/cm/cs/who/bwk/interps/pap.html : fill-vector ( n -- vector ) - dup swap [ dup pick set-vector-nth ] times* ; compiled + dup swap [ [ dup pick set-vector-nth ] keep ] repeat ; compiled : copy-elt ( vec-y vec-x n -- ) #! Copy nth element from vec-x to vec-y. @@ -15,7 +15,7 @@ USE: test : copy-vector ( vec-y vec-x n -- ) #! Copy first n-1 elements from vec-x to vec-y. - [ >r 2dup r> copy-elt ] times* 2drop ; compiled + [ [ >r 2dup r> copy-elt ] keep ] repeat 2drop ; compiled : vector-benchmark ( n -- ) 0 over fill-vector rot copy-vector ; compiled diff --git a/library/test/generic.factor b/library/test/generic.factor index 08b1f95e23..7b039e6cd3 100644 --- a/library/test/generic.factor +++ b/library/test/generic.factor @@ -151,3 +151,13 @@ DEFER: bah FORGET: bah UNION: bah fixnum alien ; [ bah ] [ fixnum alien class-or ] unit-test + +DEFER: complement-test +FORGET: complement-test +GENERIC: complement-test + +M: f complement-test drop "f" ; +M: general-t complement-test drop "general-t" ; + +[ "general-t" ] [ 5 complement-test ] unit-test +[ "f" ] [ f complement-test ] unit-test diff --git a/library/test/hashtables.factor b/library/test/hashtables.factor index cf7648aa5a..77cf386e86 100644 --- a/library/test/hashtables.factor +++ b/library/test/hashtables.factor @@ -11,7 +11,7 @@ USE: vectors : silly-key/value dup dup * swap ; -1000 [ silly-key/value "testhash" get set-hash ] times* +1000 [ [ silly-key/value "testhash" get set-hash ] keep ] repeat [ f ] [ 1000 count [ silly-key/value "testhash" get hash = not ] subset ] @@ -40,11 +40,11 @@ unit-test 16 "testhash" set t #{ 2 3 }# "testhash" get set-hash -f 100 fac "testhash" get set-hash +f 100000000000000000000000000 "testhash" get set-hash { } { [ { } ] } "testhash" get set-hash [ t ] [ #{ 2 3 }# "testhash" get hash ] unit-test -[ f ] [ 100 fac "testhash" get hash* cdr ] unit-test +[ f ] [ 100000000000000000000000000 "testhash" get hash* cdr ] unit-test [ { } ] [ { [ { } ] } vector-clone "testhash" get hash* cdr ] unit-test [ diff --git a/library/test/math/math-combinators.factor b/library/test/math/math-combinators.factor index dec33d53d1..232248e079 100644 --- a/library/test/math/math-combinators.factor +++ b/library/test/math/math-combinators.factor @@ -2,19 +2,12 @@ IN: scratchpad USE: kernel USE: math USE: test +USE: namespaces -[ 0 1 2 3 4 ] [ 5 [ ] times* ] unit-test -[ ] [ 0 [ ] times* ] unit-test +[ ] [ 5 [ ] times ] unit-test +[ ] [ 0 [ ] times ] unit-test +[ ] [ -1 [ ] times ] unit-test -[ #{ 1 1 }# ] [ #{ 2 3 }# #{ 1 0 }# 2times-succ ] unit-test -[ #{ 1 2 }# ] [ #{ 2 3 }# #{ 1 1 }# 2times-succ ] unit-test -[ #{ 2 0 }# ] [ #{ 3 3 }# #{ 1 2 }# 2times-succ ] unit-test -[ #{ 2 1 }# ] [ #{ 3 3 }# #{ 2 0 }# 2times-succ ] unit-test -[ #{ 2 0 }# ] [ #{ 2 2 }# #{ 1 1 }# 2times-succ ] unit-test - -[ #{ 0 0 }# #{ 0 1 }# #{ 1 0 }# #{ 1 1 }# ] -[ #{ 2 2 }# [ ] 2times* ] unit-test - -[ #{ 0 0 }# #{ 0 1 }# #{ 0 2 }# #{ 1 0 }# #{ 1 1 }# #{ 1 2 }# - #{ 2 0 }# #{ 2 1 }# #{ 2 2 }# ] -[ #{ 3 3 }# [ ] 2times* ] unit-test +[ ] [ 5 [ ] repeat ] unit-test +[ [ 0 1 2 3 4 ] ] [ [ 5 [ dup , ] repeat ] make-list ] unit-test +[ [ ] ] [ [ -1 [ dup , ] repeat ] make-list ] unit-test diff --git a/library/test/vectors.factor b/library/test/vectors.factor index 33904da9b5..0b901472e3 100644 --- a/library/test/vectors.factor +++ b/library/test/vectors.factor @@ -56,14 +56,6 @@ USE: namespaces [ 4 [ CHAR: a fill ] vector-project ] unit-test -[ { 6 8 10 12 } ] -[ { 1 2 3 4 } { 5 6 7 8 } vector-zip [ uncons + ] vector-map ] -unit-test - -[ { [[ 1 5 ]] [[ 2 6 ]] [[ 3 7 ]] [[ 4 8 ]] } ] -[ { 1 2 3 4 } { 5 6 7 8 } vector-zip ] -unit-test - [ [ ] ] [ 0 { } vector-tail ] unit-test [ [ ] ] [ 2 { 1 2 } vector-tail ] unit-test [ [ 3 4 ] ] [ 2 { 1 2 3 4 } vector-tail ] unit-test diff --git a/library/ui/console.factor b/library/ui/console.factor index cf1a498ac7..2c2ff83c1f 100644 --- a/library/ui/console.factor +++ b/library/ui/console.factor @@ -105,9 +105,9 @@ SYMBOL: input-line total-lines fix-first-line first-line set ; ! Rendering -: background white ; -: foreground black ; -: cursor red ; +: background white rgb ; +: foreground black rgb ; +: cursor red rgb ; : next-line ( -- ) 0 x set line-height y [ + ] change ; @@ -121,10 +121,10 @@ SYMBOL: input-line : draw-lines ( -- ) visible-lines available-lines min [ - first-line get + + dup first-line get + lines get vector-nth draw-line next-line - ] times* ; + ] repeat ; : blink-interval 500 ; @@ -158,7 +158,7 @@ SYMBOL: input-line scrollbar-top width get scrollbar-bottom - black boxColor ; + black rgb boxColor ; : draw-console ( -- ) [ diff --git a/library/vectors.factor b/library/vectors.factor index 2ef7d37c99..ffa7ce67d8 100644 --- a/library/vectors.factor +++ b/library/vectors.factor @@ -82,12 +82,20 @@ BUILTIN: vector 11 : >pop> ( stack -- stack ) dup vector-pop drop ; -: vector-each ( vector code -- ) - #! Execute the code, with each element of the vector +: (vector>list) ( i vec -- list ) + 2dup vector-length >= [ + 2drop [ ] + ] [ + 2dup vector-nth >r >r 1 + r> (vector>list) r> swons + ] ifte ; + +: vector>list ( str -- list ) + 0 swap (vector>list) ; + +: vector-each ( vector quotation -- ) + #! Execute the quotation with each element of the vector #! pushed onto the stack. - over vector-length [ - -rot 2dup >r >r >r vector-nth r> call r> r> - ] times* 2drop ; inline + >r vector>list r> each ; inline : vector-map ( vector code -- vector ) #! Applies code to each element of the vector, return a new @@ -113,34 +121,19 @@ BUILTIN: vector 11 [ rot vector-nappend ] keep [ swap vector-nappend ] keep ; -: vector-project ( n quot -- accum ) +: list>vector ( list -- vector ) + dup length swap [ over vector-push ] each ; + +: vector-project ( n quot -- vector ) #! Execute the quotation n times, passing the loop counter #! the quotation as it ranges from 0..n-1. Collect results #! in a new vector. - over rot [ - -rot 2dup >r >r slip vector-push r> r> - ] times* nip ; inline - -: vector-zip ( v1 v2 -- v ) - #! Make a new vector with each pair of elements from the - #! first two in a pair. - over vector-length over vector-length min [ - pick pick >r over >r vector-nth r> r> vector-nth cons - ] vector-project 2nip ; + project list>vector ; inline : vector-clone ( vector -- vector ) #! Shallow copy of a vector. [ ] vector-map ; -: list>vector ( list -- vector ) - dup length swap [ over vector-push ] each ; - -: stack>list ( vector -- list ) - [ ] swap [ swons ] vector-each ; - -: vector>list ( vector -- list ) - stack>list reverse ; - : vector-length= ( vec vec -- ? ) vector-length swap vector-length number= ; @@ -153,7 +146,7 @@ M: vector = ( obj vec -- ? ) ] [ over vector? [ 2dup vector-length= [ - swap stack>list swap stack>list = + swap vector>list swap vector>list = ] [ 2drop f ] ifte @@ -163,9 +156,11 @@ M: vector = ( obj vec -- ? ) ] ifte ; M: vector hashcode ( vec -- n ) - 0 swap dup vector-length 4 min [ - over vector-nth hashcode rot bitxor swap - ] times* drop ; + dup vector-length 0 number= [ + drop 0 + ] [ + 0 swap vector-nth hashcode + ] ifte ; : vector-tail ( n vector -- list ) #! Return a new list with all elements from the nth From c026fd77863fe7a0b5307fdcd451ef76cde2e144 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Jan 2005 02:00:52 +0000 Subject: [PATCH 032/122] added bitstream vera fonts, sdl console uses sdl-ttf for text rendering --- fonts/VeraMoBI.ttf | Bin 0 -> 55032 bytes fonts/VeraMoBd.ttf | Bin 0 -> 49052 bytes fonts/VeraMoIt.ttf | Bin 0 -> 54508 bytes fonts/VeraMono.ttf | Bin 0 -> 49224 bytes library/sdl/sdl-ttf.factor | 7 ++++ library/sdl/sdl-utils.factor | 65 ++++++++++++++++++++++++++++++++++- library/ui/console.factor | 38 +++++++++++++------- 7 files changed, 97 insertions(+), 13 deletions(-) create mode 100644 fonts/VeraMoBI.ttf create mode 100644 fonts/VeraMoBd.ttf create mode 100644 fonts/VeraMoIt.ttf create mode 100644 fonts/VeraMono.ttf diff --git a/fonts/VeraMoBI.ttf b/fonts/VeraMoBI.ttf new file mode 100644 index 0000000000000000000000000000000000000000..8624542ed208db88b2d1e99bcce1e1acc7e6c28b GIT binary patch literal 55032 zcmcG%34B!5-8X*DJ@?+(GixS$GLvMo?<;{oCLtjSSxG_&Ad-*-637Bc01;8CBDILP zv}oN*eJG{Y$5I~`sus1P*1GWch~=SZEfuxCMYO!s$6|8%f6u)$S-`f>=lMTxhMBo@ z@44svw)5N0?_3BagxK&Q64KO~o%iG|Uv4Ahh4*l_y?K6pTlbIR))Dez0e%;C4|c8J z|I(lK5%NS0A*`c&)0k)fyl*=RiOV5`7Oh^tX7H0me>qA>!dGa&YfabadZNRN{Pqd_ zHm@1jvih!{cJ>jHcrzh;e%04Ac+IQ%`SZ~K03o3@eZ5^hC+~^`=hu9?e9f<&rsK3 z?|o0!X96}eA+d?;heyZKQhxL|LZ1Ckw0~&*NbmaNKmWn^(G)PT+i{PZh7e8>{x=(M z?U<5q{L+pEVkWJDV@7@XZ7$92-MZxJv_J`&3S{dKJ-4&-`zU| zBBaDG;4R`)(OHkDYjkwDyT1$Ld3uJsHxBj=jdhK2cvklh^p1K`c#rB0p4Q>jW1G81 zdgD`7NFdK6!#x|jd)01w`oXFGRU5~8RT%gPlQ(2|`iHs)Hui8xHusP94R0I+FoXSp zf%ph2??*X;8%KdCM<>HG*sEf_ej}JT+Lz&(8Y6>`nLRw>8SRBgpmje$4WNJ7&>Tl} z3z}iT0O{0$Hunt=UI{B_!|IJALl_Vg!Hqq`p3&h9&*;WgYkRxL_!*7H0|UdGIYQmT zLp}YRV574+L)(B%*Q()7y($ixNUI=B3c}Fv7#INtalklVRM0dT(5`t#`?`SEs@?$I z07(Ckho73lba)7oG2$5<9#JKP!!!eN&)Amry{o%0P*xDEnb!xqw(t=KhkN>0_j6(E z8W@B4;Q-xs_4KINt90grukRWG)Efu7MpX2BdPn=$V4{KK(6j6Na5SPyX;(Ko8Rd5b zAsY2uHj*ZFJsQ!v2EMt2z&$}Yrg{T-Ljzkp{WC-zG#KgS3RvYBKN$6Zl$(zkYJUr4f>WQD6uJIgr4lcjoiRWq|K0q{Zr#>)iR`p^&@qRag51eSl;lzFIqv?szX6> zL0$I_tk!5(Q{`FE)Y#@}ZCcQ_q`aldQ`_okZfR<-t*ol_#Fw|?cYKCtNo`wA)8aM{ zTC|imwk`EEE%1~#F7?#aHdbbMsydoms#;q;O)Z|Q-S*$ zo7z0}wGFjx=(Md#y*1EPZ58fY;AyC8nO}pR%PVT@YulD)cox*QHS#_epwn_sb9qZ! z?fk{{2+s z)llA2m%$-yYOASg@u*F*044hHRJHS)TWiYe>pc~^%Eeo1j_Mmz6zO&ek0K3 z{j@c;fFJ=-mejUZWq8V4YFjx+7PK@0T+UD2!Esy+dZKA*At|Jrq~bddzGn`}$I&XZ@Q@0$ z86%^3kC0x{MFvR*&eoD4w9mp(IT^sqLs};L8dZPw;+|gIvk9L)XnAEn9@4J1=tBEe z^gM(+Jfs1z4dKm49!AeSIBEhc1L%JP*@!z@@E*XsOC7;Oa?yJ(V7_vMVE@71gMDXC z_RV|#-=l_w82{V!;BBvjcsfn`ReEshaN2i)61|{)7mnBA+%Q?K(&!&?hmXPE&A4*} z_wpV`@yRLdQGa>BeSWPs!0k2aNJAKrbB%L)wR*L8a>Q=j!C_c~7X12{$}7%2E-mZT z-bMo>45QaEwC=}M{$7I?9G`An=kgcCVoZgCkHsP5(#G3$tL+BSQtLg~18=R-hRZ}Z zM&y#iAxt6hWWi(~@v1!Yd$|m8Y2k2nIaQBq7UA8aEu@h zSB}7Y=XB@>WE;_MkS3dP#P1$f`|_x>h4XtRM#284<~_$vo#Ypw>USpKD64VKf{#1f2GKP6ss`ho8?oK2J4Wr$Ng#E!VX{-cQN1Hut!^@%gUN zdLw$_zoxL__i`<}1~izG@-=A3G3pDP<97sgDaTNQgtynIdpV8xm4A%W6vs6TrX-DH z>H$3eT?l55b2&YxFb&dwRGkx?=X?Z?!E`S3*)XNmIki11&4)lYu3v(5_Mnw^hU2P9 zr8WyR&CKb--`tAy;z*;=bjoj5<*Y}gaQrt|*Ld8i@i<7`;2m7A2fc-O_!HCTrDkjD zG2(Pv!{v(4X^w#gFP8*P=it2Cgsc72unUgaORiD5&9UOG*W;yGGCupc#o-j@+GdKr zLAZlwuCxpqSGfJ+Hl15LP4>B6bSu=^%G&iS$tcXN53PUUZ+?3CZaX*|Wp znUv(1{UZ!!${p9Wn*XO^6P$HHyTLsPZSHYjghR;hm~M}?nc5A1sS8rWN7rnvCS6k+ zHrV6;3$1netewJ2^RKxaYxZ&V47sZzRVuZbNF!;(Q7gRQ1vpv)53@zRR*Q2U_;xM0 z(hiTj5@#!MCLS&L6@EQlotaB;+(v59Zn4^z)<+B4@xGU$E$^HA@{Q`RI<#*@UtIH5 zkq&i?D)h#CZNhlG?*^Q$$2T97x8rxr$C<_W&5x^bt|BmABktlj@b(ROw*??=!}+OE zXF|n$*2d$IHQ-kZ`mYJVT#mkL)&4mAeEbD!zm4i${JsSNNXv2DjJsMeYAt$LjJx`(wN5>&(U8-GbD6_3)eDcQ_}Cg8oc`^B{YcRY$18*#?}` z`qg^%04k0Nhg+k@V*IW|OHK!lA@74<<6PnNte`wG^mjC`#C0@B2&^Z z9g|>hGr99k(h(ei_r>|fDOInI(hAB}fma+Z?F_%4%N3XW`M_XG;xxJE^bWSwsKEKt zsB(4@_^fe6>(8T7VG0Z0*AkTzQ~c04z#-(6;3EcUHpP8DCWko)50_>xWkEhnQH9Sx zE@ONoE(QD-AA!#iE@PZa{915+YGVZXxLCb6*ekzpru1_upqP4|R@-iYQ+YOxZx zj~e{kL*hQW<`Z(?PxDeVUxRz)T9nPB0WDGuMln1(}&H zecacct=>D`FXes{_t-U=(lP`593N*5#^hPDF+ek$WaG72ePzL)(CqhAb}UOBX^m zW`x8@@5(MfF-$I!cIqG(#RT#q`Bdm(SFs1ENNcD_j)?RBQ*7n<^ zZz=3sFNoW3TqBgn(M!$GN61zT+ZBy8Fp=|55)zVglZ9RPHZT}_l z+AZbMwbg7(IlE?ao^;JRwmFY&QrJd?ja_7;7ukryHaOUN9~%y50}5NW)*`L7uznls zzftU4)b55+(na5UM zZIxC=u&b?X1x~C0Pt0ujvS+2`3R|{xg|zHhw(Lf6X@^f*x`HkBiyc0;L}Be{+P;k~ zM%Rn;SQ~z|C9~ERr_|cRTAXarUe?^hnp#-{t~BJadbF$0V|C$dAx3EGxfJ^w0H4{uRvc7t7YMdH6B! zSvJ?lO3_ygs;va}wSs<0G=B_}zhdJQiwXE@!yps$)*UAvwdD!(Jdc z<}o{d*$bGhj#+VJ-OECXnWdPSZOp`CC6mACA~PEDB;!S9z;#0&)9X4U{Whkg86Mjq!B^XJ$iJw= z^XsMF%#6!^dTct+A<}%vvc+@w(xv7OF-lr`NQyqheELJ8FX8mxyLdV?qprEbbLhUR z%0RDGos~G(+JOP^kDtb9Rh1~u5lEl1SL~Da6NYM`NWWRUm&o^0y;LlSB>U*`v$@1} z{Os|wIZnIR?(^EceIgkjWl`fFDSLGxU!5P3Q=vUuP{VTrv?U`3vcjLG*9iuh8AOA` zMA0BHMi|ArKu5$9K`>CABuscfduf$Q3OR~?rcQgmk>ZH$f zwyC#0tYm3C^)fHsEWt@{rN(0AOXzyz4Xa=E(kSI4>D`G9%Kfw#Sbf4CVV|fFajZ-d z6mp542(qZR9e?Ba8^G#9=^J@D6j<>W`{WYgFZA%Pkj~#kxO4)QP8Xyjz$%V3`tzeq zB*q|xIjs>EK_`aV<6>i?qaq{1+@UU~!)~*NSj;AaUKikQtj8Gc!B~JA7?mE)J6?(b z1D`oGf#o~#FQ4V>aENz;Q+*fbI}`90zIc7%>yE46y!!pCzbN`k4c=G(e&w5Ze^Ge8 z2Jfrc2IUk~=XdBPi0;i8X* zxqOK!`qH>qmou!?8yk{svqqUb8F3+c9VN0DW{Wa;Gs0uDQ&J_9=t~qcOi?*1&0YYH z!oVPvO<^T=exRauH1F*3qqbMh<^A>*oI;x%%8H5#3zC>qmP1``;Fgq>>~y=s@LgC? zR9u{|!w(%!GB>Cv>V%zhT2__pEv#uRh}>PW_=&FkrH?PEeDHxwujlN}uD+{2uXN8M z|Dz8pfBU`QQjVEcRu;^odDLxKR+(1v^<6Ym$jYGd+zOE{OWA+j&p*?D_L&$RaWOeV zQht?n@LPvJw-O1~k%%wBj+;mriGo$lC++^ssPL4y2y>*vkWv=sC^MML*u1!`GG9bw zZhTa@m86T&xng{%C|kvNQeZoN^z3_QZRdV}j+21Df&RI-zQhR|Kc!NnB*$4$l%EH* z&B`xDN9xyqqObqrmYbh@ z?&e#5LFdkDYAl((s736!h2x>mFU}t%5(Tx=yS0|;spOz#3*>ugosB%VuM zIqXkSQX;}BgZOiW@rJ4{1gHv4O+b6m7UjHHEITmAV*D1FREOw{vV|~a46z*_KdR|7 z+c@qN1iQ--mXIVA+E8Fv{OSLhRdTwenKDXchw|%*A1SByC~qEklrH=sjTaVBFKQAu zDCb$b+IO5kgvf!ujnJg%{OH+$w&cA#9Wcg1a=zOUirzP^K_Q5oci|A z`~yE#o_bjM{lqiM2Y{Sx5lX~1$c3FO^rzS?CL)>*I#CeyOtPDeG^E0zHyfEjwnKLd z#44H$7TIAt4o&tR-kASjHKz(cbCjRJ?;I*gI-fnkE+zYX#gaYW?i1UTr|80Z<%vg? zC+jJ`>uKGiv|fDiUmx3jSUE^L4)1>KUw1!6JCuV@0jdi4^1H=@n57AR8!^xtNyp4E zMUvhqoB8PDrAN6*QV%#kLcJKyTj;e5AJE5?md})CdPqE|w4CDy=jdbT^KIp{a2CG0 zL<;=jFujr>OGJW;FBLFSD^pQ|;)4}B`T}|eHK$Au#8ovp6z1k}I=e_Yf8tR(to%jU zPH*5eyg;90`-BgmZCy_bL=<4oxUg`=fUg|YSfvXaXHDEDe4xC~<>e}v+%EtNBia5? zLFSfGhPEyswE|oM?fx^i7r16Qt4$is00u1I!?baM@;E@a6Qh$$6=J?><0Acr0s*qh z0m#;dhqM9@+=hsVwS6%D$otZ}e;dTO%b*W7gYU3runXt?Zf3A9OblO`S&>+kBa={l ztXWTzq4F`Y&)VJsCTA`{=^cM7$NwwDX^51vS+B{tFhB9NBsgn6czvP$wI={Zku$VQA%~G@6tZUXUHVl(tx=vWf)`{!%>kR9R z!=^oC58Wl~V!Om$`dx-y#yzHcgnQUM;vM20(jD?0x_k6@=t7&dRrHs-}B;0;nTvJ z+JgMr>hTQ&YrF5ISKTnOuCMod%6|ISca_>7+wSjVy(B;nHM@M$U-4J!fllZixjBa7Qqa9H;V*3XH^}~l{`!! z7uySX@pF!#*8fb^`qF2b3>W)~ib;UnQ0=Ozq&m7v=+7Uo%cY_DSJS)Jcenieru@O* z_P%&tnVmvKWqkartQNZJ`!$Q^%%-N4v?F`}rfiJ|{HGz!oq#`uH25>zq(Si1$JHe? zM4Rg^b%q98MRb*r>cPwsQ<>Sq;@onQF+w&v<5D@~9Ci-3s>qH)%(^mGTfF>7xBic-i&r#5FRRc@Vfg)*S5YoRMhuk#~WY%^2fK_to%axWc5ea7IhvQ zxbNZZ0&)VwixAz3-MZg1)4p11?N=!8TFuqMO) zQfgrq95ZGy>GTG@QD-pd34AnB5(S+ki3Nn2bPFZQN(?3=oN&pkI-dq8a@dFW&IAz4 zK6AYEY+jHVT$|{pxz&0YVd*t+hI*Y|)e*(FlZi?U-S|CP`1t&^~aF4{#o#QnOef(DQOSw?Awx( z#OdF8=>zdjWKK-*4rlpeovguaXo$Ado9k>1K1foE6TY;WZ~=--QKKU65_4T25S`z0 z!BG{7=JZj`iO~hY4QQ1j?%=S5i2($i^ufIM?@4M&QJ7c*f8HC)t20q9n z-ybIF1ST*Ygrq9nGKGL*sA0lbD|ucMiNa{Vv0&Lg~}$YH()!C zgNxiNRw<-0mHUY~PsOFirNyN)u89La9;On_qJ;%S)dsRImSUQz)GBfY-Dj|u8P_de zfBW$A!QINizI8PD-6u~!zIX6i<;3Uz@yRQHSYF+`{i@chw$b-H*4(qHz3(3Sbky#l zr>XeL55D_GM9fdNzNegf^@*Q+PK#?-T(hES>2;jv#g|Sa`u#$U2nzhsy0``-ttWM2 zLxj->^$}5(qKl3&1C z=HA4zU~8R$~}&olFHqrRmLecy#7+z~^~8k2wjD>#Nr#xI^!y7zv2M=bkc zNAIui>R9(1K#Y7PVfA7%c%y^mNS*Q_;3A7UNft$2fq>-&u~wEP0nQsGW|8U;_nx_M z<^?qxJv%-_2Bs_rcUbs~DzvdidAv;ZHpFD*ZskdM90GYnIjxQ@AE3^ z^tEtjYUM_wp6U!#<{>v?`=e)$pLs!bh|Z3`VLLb7QU&KTbS-p`mu{ww+{3!}Id$-$ zpT%BP?&eb7K?cPwJUc<+{5GgSN+gB}FOU$?qO*;k&EuRo{sx>-gAhs!skmkQBNp}b z2cnlfq{1E-Ia8m9D?hDDV;) zZE+){k0CnU>8}%+BumjTv2h+L%F9&taR(9llogn4MsJ)!7L75YbB;?Swo+GE1rcH* zy>TW3at;DDxQN9X2@f#R$>MEC;V68}12C8YKJDN7@|AP8H`RztwbauY!36-!;9r`8 zrQYJAqB4O;tuySO6%GPjrsZ8alrLi)9V^!9?_5~5^v$ut)xYig(JQMq_Uo^Y=D8Sp z=Y5@f8dvD9pI-uj44=$ZoUKHPyMxkrVNSD7LGbgnyGE5FJ z6S*mjG@0$q8L3SC9bzJSDYP-=qFV3N4U7)(K(8Ar&dv0bzJIz-?+2mPe^c> zO@hT}cO=;Cg4JMmI1&mXNSo2n<|v_U#@2YFL64~{o9xbb(Gd|M>7zsRZU;$7v>m@N z>7l7w>x}B21u)PAc2aD)^adP+$K$M&u6QEO5*H$@piJ}95=`*qRdM!t)!d9~Vr1^= zd+F}>mmj!$?QmP=%Uia#FH`F1AKy7~MtEt_8omfQpz`4VPv93ttcxW#0CbUU*xw$699n~^>7#My{7!eNy? zJfwmR=5jjeYv$0pL&mm_UlI@Tqbm>bTzX-ay?EAA9}hx=Nhu6tS@^9y&qP z-gW={S}tE-fp5DZUnUZXjBUD_w3Kwz9vNvingj!}N16*rySaq6N0_+#Y>6=I9X2zG zj8gdmG&D;R@Fu1+Vrl&2aR!wIx;TA+1%U{QdOaeaPa#m1VuDvNKhwGXzVw3fZQGS! z(m6DSMn*;Z`f9FLE}l}J5?>!L>*!cZeb?W7BQ<{c)smMt-18q*S2cr7$fApK08JHgagUWV<>&QEVc_J#&)@tm>^+1DN77c(u^XBaP$ns1u9V!s7XZ_$TV{u z=!HY1Swegs8DB{~Y=8d54urV56ED^aTU9^u2z<#c+%jbYnhSu&K$<~GyIv>Rbx48Z zfZFwXT>(HL?fMd-6&hWgm^wJ}2Aygg1CVf!_nQC-fry6Ic>S@_2=~c$ki)g7^dy#}e9oanr>z*_W6QZ<9!L zk~P{PCv$rT2a(eyAe_o^EvFd-i%&7lKm;TiU+3xPD0F^^$>Hvsd+N5 zA+6vHb3%GlhbD?957P}pG+B9HIk{cAW4i)iCtejwE~X3jPGI9Rh2KfUr&J6U`jaHP z(PR|uCX*3~sdfro-mWvipc}PS1xYZO^hPeg$N_L8u1!I}nl}lo#vx66b4Z-jn9sK4 zD<__#sRiTT&Znu*iEpa`b-pr=WWbxC;#tVfcEI2wE&g=9-DEaNvLNd0X0xfl3@ZkW zCbm2D?Zy&ERVb$$l|s!X5(?82h@Arw8?-_YkV$Fbd4FzI0Sb3%bgG~1DsTMxnz0R0 z-&O7@5ca(4ZJ9s+sSU%wZKNHYD+g{9&Qo#R_{gKh#j^@Qqf6%qkvdcwZT43n5(a0{ z4c3;p*TapW#%H}jz?Vd@T9+UgFO+m^$GSyY8!A(ntb@Xreq+&Z`3ZLk}WD-67h z4r&uZnN19nY?4iO>1?_%y-n{jxQxj>wa8M@a1NWLcdZ~RxBz>3_7w&^;S<`GOH*l| z^1;Ms%BfS?pCElUu|e2#FWii{sxx6B+dnLbH9EGPTpM1(z~JI!>}W!*>AVDC$sk0isY&^;_#Xs;c05bqG@l~ z5`Q}OoY4ZIfE9{`A^FyPTaG=)k>kv9<%H(AbHZ{wIo_Q3oP?aj9A9WK66bb#QdiHT z#q%hI7px{hLxX8i*3-ObPEVpcJuD^`N8P@#Ojk_o_{pBd4Hq9c@!_hr#;+eZ`A0T> z%{A3k$=k0QeYNhIP1RKyH?@wws(5})@4N4|d&bZGM(Mt1_q`Lq$_8#d18(Vwo2>KC z(Y!~4Tk{?b26w34;I`WA4yP32vbzoL0@~&zZHAK2P?zdA8l48oVKESQ7-txFuT-UY zVOmm@t0GN#Ye)Em;07JTpg#z`l)$_~YTKT>?(Ey9+)4MJ{jb{Djeq*Z{z2uW_`b4m z=g#E~Up@V^kv~){Uo?Tz9B@SWMCC{*$t2hLqg|m+UwbHtXg8t=G%GaTWueY^x5EN*tQs_7EmD55GK5~E31>bC+f01fkO)^77D~hNk z5hC375KDB75EW_qGBo{cG7AH=K#@NL%^S$kn z#>IyDmUg)!vMR+Dmh2#jHlrcY8fLSyX$eLyHj{1{^3y z3coRMlwtzX@bFVo4JpPHQ;DI(SYoO*)Ea9|OASknOHF--K4YJ0i(!j#i^-8<1aVeq zsW?z2;KGHv;siA#rzXB*1CdlRz4*d)bUvkPURqvK`PA^H?;h5T-L(@=>A9hguA9?! zeBF+F7gP!NHt)UuJsO^xs(d)FY(qy|E6Xo`ddJ7gxq?EPyJ+#oo_Wh-Ks7w2M$$um zbYz=9j&N^Yr+V_T&@Pq`olKa7xRU2tC^A_Wjw3Z3@PDrKez<>HcgWhdyzY>Vf7tnl zgMT<+y=ZXpW$`0`zDkut|%mi=0 z0+dl?)IT@GZnas>)MT;SY*y7nlMK@=y@g>Z*4XZ@3ZW%fSB?m=0D1|x=ydjoXeb2R z3opQf)AAPF;e>h!T9_$0hA+Uimg*AlESXCeC@6qKHR(>FrlRsNO@5W?u4)_D9`Pzo z{zXD_S^d9nJ9XA1B(ulHv51r%+Oq80>)2Q0El>QSY+>UoPp9>8|MPXwJrfwo$mbZoo zo(FS*Aj+iUUW*3JG>0Xa%$VlF@xvf^kB7q{SmC!v2(c_pNJC}iEMXR#CFxh77Ki3@ zZ^O%|caJhaZRgDJHe@AVId4{er69ul`mpfw#2m5aVmh;pe*s@(1F$IrHYT#sUpD2B z0(7{d0NrE&hI*YI7*6@E1$y|U2DyY0ljfHaEVPSoOD7XGQ(ox|;%e$_IyPPoD@C+{ zPcd70|JTZT<(I;0#*6^W zdYMPB5*#KTyK?tPhF^rW9ikU?1|EDI4a_`vM4A$s?g&i>PxIaohTKVg&(iy8#l+50 z<!W+t+c%5cd76ha~> zpz=W;Kh0*#CbmiMUKmeM#xJn`brj+OyRVTg%Dws}T5%Ev>kUn`H zGvlT6^hq88(M$zV5SKBc#2`JvGwjwU$r3o#LN>3UIes>WhI$Ldw-L*nI&uUp>8N;) zb;_&JG8@%4NN{Qe6uj{pIi&880h&BS)!O2v7tphamtRegQ70hS^Y$ysNqM#MZOR`* zMzW!wH;P-~`=?QYS|@^PLo24Bj>>wg$!HA`Y!-Z*tvtjI_qr`6*+^EnY5Y~O zD}2jsRqmB0qbVgk%!~>}i#y62?_^Qd6lQg%Yfc;#HvaLfI`=}(1TuM8+0y7e%@^T{ zds2O?J_y1kGZ3?#WM}>ffsXs4Y_15zfHid3-?+Crcy^rjp`waU+ z_qq3lh1dieqN!_y1LOcbU^ozZzK`= zi^?|bi=o9^mG>j&|Lf2_Kc~gi_aYJ;tGil`ZOY#8+VYcs2oW58gJmtxJUTeBeOp7r z&%Sr!!(7>9E-5XUbul^l-n*0626(U=l4?Re^a=k$Xn10M8phgmhv2j9-*&1RE zaXJK-9Vcv7d=%JSve`o9QWq(Wsd6p1R$D9~HiO-4W!5mOI|S)d%?0H22j$PINr!JF zdcbHx+%@v6pOeAr499?HUR82?h$ld9U!GPCg7pBm6&l6MW=23l$M6qY7moaB*`8G8 z6wRi-&1DBx-u2VD#Z~{Yarln6Y1D6e*DHU1rEjxvOmkP|TRb+&Pn4MO$jLM2>$>K9-Z69Mr!}bbK7xREy z#Q}Z|z>ieHM-&kRpL049Rc6y2I4x!TT*JS#{!zI^hiS^HN9qgbe!KCJcdxx}!4H=E zyxy-)(7E)s)O6*->{(yEa^v*{1>j``_jmp-FK4iC24f4%F~n|_!AP*PDrUK*+N$xA zfstS*czG7lHFtQ_#i?)Nr8axGnw`!??O5gI6*K7@cuC_q7xPt)!efHs3(SK+SSxH9 z-q%_?^5bQ9ZlgXVbKZ}u_z`$HZx(pD{%*Eg`3TIUp`4k*j=!Bf(AoXok?oYO+kO}7 zzXVbb`rIUL!*d3c$Yy^+bSH`FaYS&2I=T}|&0uJ9QjC+i9nr)C)U8^c^(;p_m}w1g z_8jMI03+amoGOF`kwZ`ggdMXUvmLV^a~yLXa~+F07JDr2nCDoMiL6i;3KDtkWI#-1 zofk2mmT-mW2Ie|Dz4EQ0uN0-Dx$RH4yghCSnJ_R$Z@FpUKUW+S+3KY|x2F`RrG0j0 zH`RBo9{l2!%uTKKSZjChyg9TlB+9&a)h1LGQ^K<=7a$Q%@)Q4D$toLV(Q1?_-iXoR z@mh^Wxqz5#I@UvNJt5Tw+AG;@A$$!1cHC%%|K`#`0n083_!+KAC!Gnb+?_+6O3<%V z{a%&%0aF`DJG)fx9eZa2-g{t11l1{shbw@T@2?413Y}L6@4)FT_JT%ps16G$tiwh- z(v^dcDW@J&K2N81TiW5zzexYMe75*#{ps=T?1s~g@7#U5m~+{obchGU8=%qB$$$8- zLLy0K)^u|^@_B;QoE{y8Rakt7g$wQotJ$2Mh9Ai(LQ*PkR1g_MQq$xJ%m`Zr5IrAf=vdabKtGSV38k5k2Tr@@-;$>6h|%Z9p0bd(zxZQ=(jj-l>?24-r0Xh&0@ zn)5DrGXT3r?fV;}HT~F>Tk$DkiQ*iticuvv&MRL&}& zuX<`pQQeQ0Y}*|cRdj#ngTH92UGUo4zMY{7)b}MdJliv@{MRp54?nE@`IFcfYRJso zc-@ZH#cw~pi$)Ht85>%|D?aByqBt(VZ~Try_|J(H;gQI~sM&M(?3~!et;tnucHIyQuNh?zpj)xL9lnl* z-0d$kT9LQ6K>SR4D@F8dCo2w=`rLJ%ZL}MpPZ5%2o*A3d}l8IUS}P*Sbiu6bhA((Sh`FA)OB1gaG9U>YJ~e z59O}&d*#)kP6ywBVIZ=>rVmAgZF6CL;^>(yIKfk@R;vn_WWUCH)x?17>Vz@y zwb)Qq#e|a3DHSu**l3m)mm#NU7Qpxk8{$lXD`aF*6X0X3%N|fVpn>qdcW(Bahi_2c z%>1Nhb;JSXM7q!j|Dl5V(to@sYfi!Gbvs$x>DOsH*Rn`tOAgiU-tDiPiX5k+H6zNc z3|4K$!-{a-L_rsqP+I|u@>c&>>58$mnm0IR0!ryr49Ie z3RyL(R^v85_M13~6TCEALg1AHZf60p%C;UywcMlEJ9T_7jahQZSg_SGC$|$Xz$$Py z2BdVHr%Hkd@R=KA9%oX}4yb7#0DrkL@EdNm-D1Tm&42OK zXz9mamY&Pw6q_PcP|W#vfM|h3mD3@?xMW7k3iFuzrk;;b~lAJg*QbsMK(n>MK{GX#Wuw?d78XU@l6R$ ziA}zyq^9Jil&RYAW<#@aW!TE_l@Ti=S4ORjUKz78c4gd3&r0vg_>~DO6Ic3HCap|f znX)5phi8X(XZ+2HH~Vf*x;eRi1)X$(u;*w>-OfDD*Qu?T;JLB>ssWSrw$FDN^$GDg zCGK5c?A99+Gec&bVaN=+%Z-=Qt5Fb@98<=tWg|CUC#lbKh3&fImWf?r=fQyK zLj4`Q<}L7=`A#ga-)<-kWu?~Tp;h6;>X5DGa5c`>65d$JQj0_bUc976HCo{>Ygw^) z>w&J;Ee9rK+CWVw&MW_>{Po0n;nBfO$`^00-9qg}w1VFGm)|PCRM!6m*5#DaF5U_L zI1!mX;%|tH64S1+KS8!#j(SQQUNQ{Pgo1oOE@9&D+R=5mm-;~)E-%?Uv96W zt68sydSXOW!-rW-%q?6NoZ8N)u3Mn|HK?iraZF(Tag95TZR#Za=1L&GL=mKTU~@w8 zv>26c-3qTEllr{X`&Zokh!(rt@%r!&5v2Zj*|CY8vhm=mu2a9%HKGHCYO_827wBsNIh{;5CmjduCHRNX)h=eh9y=K28w_#lTn^3 ztDK?VL=~=!G+JCvA6y9-p{bM!6w>AKIxPl$oHJcj-L$xmwI?ICdq;VHRE^W;&06s9 zW5aj8KD@7u2k~sr+kg8~XkOW)1$N)MbK59_zMc(g(8p)>ebDo-Lu%|;nJCo3=ITXQ zS=nmPTg*a;3ExI5D)S3Wc9f$MJ1Y%YZs^q^=Y+ZvgWbT(rjDNpBrY*?d6f+`^<^?K zsghNM?c51*s8-j3T>$}qDhtjyR`}seXu=RC?#@W8*N^e87!QD4HmS2oWZ&S2T; zsfUhDjEkL*b@s=iyo9Pdeii_OWb&N9R0TRNR&Nk=#@M*n0;4H5PNbooF4{@LOI>w# z5#g&3LY`uZ3Wg*7)g5Qo-CJYKkXAl%Q9ktx2h$)A^LmoVcRHTlVoRX zU^xoA7!m67%6f4@Ufp9Wt{$r0zVOCP%4dJ=JJy}weq_ba*10=6t{tJaKdyL2oU0TT zEtr#8>xNH5vV{x2r`@#7;rH2ri9PrQ6%E)B1WOYTj zL~DeL;*G+-2v>pRGKI1p5=MJXJ(e(cWJGwVi*E+znQKZy1iL-brdI60jp2!_3#CWT z=FQaJff*2#cvTM|p#vb0*qQP|dFm(V;DDT$had3@CWrv^i>ayp&H&6OTfesy}{oGVrj2WNPDXl0%to~H9K^jhfY-C`&3KjCk> zEZH+<%&Z|=K#UvIkgZ_KoK;z9uNB6OuY1X$j~&`Qgoex3Fa&33)eI1KS`dGLEZP#- zOtUuSs!a1(G&K>>mvx6sS{Cd|VyUy}auWGXafUc!oGH#6XOUK*^g<(-=BiJnNsG4b zp$Ru3C@X5+5PdC8IH{cSW<1in{X2TPQ#d)%7F7^2yX>~_2%Ep&cVJon?wg})fc~S9 zmt&xpOb+@JWSqc47GhYeZ9$WY+>S_$^rA8zWlOLe|9mYCsSUo8X;3lLsTg9(VoDq) zeKyqJT$W3Qbf6(%;Qt9oV6xc_f|(gbgB&45iV;$ztY5*sc&r|Y$0klHdv?*NX1YV{ z{CXe4vb)%jsyh&gWCABMIpnXHv0ew4_Ma`-_5KeR?9@nPa>Xu8t+LBX5>i>JIGfED z>#zqwXJVpWG==HirZm*rWU^9PDwMKX0sm=M7 zxN^1fCnpN8f#Lz7aN>2g?CX6(5$ODWY}=3!xMXV2Gzp zpr_Gb1W);zf*xg@SRpg&L@Me@uOz5N5AY-OsAB&gE$6BH2ImlHVI%}xGg&<&aXl4# z*Bx?k_J^uca(S%gH>Zl&0bC<26_zp)R51vA%@BMC*I!o>s9SmW5hOmJz(S!yGrvpC zV&}w(iPvb4@_^7HgeWgjJX(fcI)KO=G$U42HIxH;L~J@Nm*GE3K_Z`6Ey&#CGsJ>R zX1=&$F&S*cB=xY>A*Nm%*M?ZzCD>{z*{q@si#wS2T3oKKeDlC1U=pub^5j!r&$p-r z5`Z?9I>-l1QRkbYb6f@y(JUbTQV30_JSH!Ln#6*ski7n1uKyx)bC$rLPbBAbHc2p_v4b7HRGPap5g6keJ*DRzD|(Ru14 zVIOX|NqJm+261){`I&!pyjMu@SP_k4M+u9HvmzwT$P+bdedp$RzPWpDj7?2{mWtm?+}gJ^D#^3$TPs`j`c#9yvU$(* zgWJMp%{q}Y*Hu6F`Jo3+{Naux?YrOp@h$eyCG{~?$!})Ovd_tfl+!Pj7~!NGgVjjB z_kZ2g-haM>AN$OOlOM`4U-4om>^udnBUD;H>F?LVh4hScEc0TEqctNVU5o!^x77+a zOHFr3`VeazT(0!oDoPoQ_?9G-CE1}%lEbQVvolCsOgQSGkkaB# z1hwZTC;3v6qH>}@?kttwe78M3>M3%A(ppTYkv!;MUP0=~m_IB)VD*s;Dyf5XN9qC_ zebhRWN#Z9Y$XnNRL??T$-+px)r>m}F(H7s`Z|--oR9U}rY@To4?wev#(_i^&@1DhX zyt)57PFq`3WOdrxIYqY8+#{VM34_)Xp4qO&3!Wd_d*b)%nsx_0hJ9G+sHRExhhmFF z2sMesAr3@1229ZeWn$6T*2PzX$9b`giXgNE4do@o$td1Z_a+spn=8ZIVSI^8+)}rv zY1sz1sbNii);(H68@*deye=C5qn$qVD`u924N3kiI?2zUkEi9VzHRxJaJ}=*^48)(_wQs9UiA6 z&Ku`+Itt>PW@at*7$VqQ&mz0U=CQMQw>esNy1j8$>3|PZdhX-jzGXYd(_I<^VFb16(%@GxNvD2nuQi6^fZYU~h zXe=yhpjGRXlcCDShn17UcN5coylL!Uw(>DlzFTfCYT&IJl&>$|z_;~CyA#(IZajE! zj>XliOS4z}-_`3cHR0$-LO6>~Sjd+zqpsx7OxHA9m zUO6%2O767YZl88#r(81a%70F~vQfvM8xw@!y}*^dpblTrO~w=S_@55cL5&Sy@d}OI;T0jFE= z%KX23<;09De4OAtw+F89{8pbzokf9h@PE0fi_!sa|b3Gik$tyuj zue=h(RJ#HQChrMis$BtpCa(k`;IWEE>kdBhGziovMx{>hN)Uo8uLL2`u5cOz?@=Lu zg?;MM9B~V(V@zb3KU;`_Tw^biPL6?_E%BoQy*LLI4<)kMU^MGYs;`eKBfZ|NgG+cu z+qa>u?%~NPGdFIinY-W?%;1Wpu!RylHzi$p;_XX#lF1Y4v>v;UwtevRufaqVV`1Ug@YlMT#$T<2PJ;x0^comQAw>gE$$i*GM398uig{`RwdVxjU?O15sIUdl>UzQV33 z3{_NNHQ`g$or2>t^w&wWpn}jE<%GZyr-NCIpU$J-}RE;9r{R{Lucv0$}8193Z zb#{l{q~nj=(YdL^*rQi>jF(1K*vt!E`Vd<*68~<^<;7kZBMEi7LhV+ReDbO+E&+k$ zNj4sw1@9MYyffClg9+S#>4xJAGN?WfkM8k8R0H>@*r6sn-Y+cOG_U`LXfJI}R~{>) zr}M{M1%LLxn)#|PpOViP-XR@QzD!NMWzQivEPTrkZ9M%lHJ|nHHN?J4bHxN;>BMt$ zZ}m48&&n%_b7GZ{5q+$0R+$)@Jtr$~PI~AZSNNQ&iu9V|S>X>-!-c?n64 z?%Am&^OEA}!pzE>$`)Tecd);E@$g7y`sXjT{Cri`!iVbGufEsOGuV9XNPf zqKcz3I+BuSM;2L=B9l8(68z!9v5(@tm1U_lRrAZQt#8{qKfSl?-XpQGA9>>|%c^?K zl{KSvEAGonT~+qrulQ3LD4~1U+lU>)i0w&-9BwAaYpX?Ya3!(U6mVOnW+VI=N{aJ~ zZmg-jDX*}oxFG-L+L~__=&9yz?0ofvVi^gqMH%PE%S9>Ec}*28)-b@T*$ld#^k!VT2%=# zRKLL%h@cnset4-5a3jJ#K~@eQp_$Js?;hFz)5Ek1g^H_X-QWJk8Xb?`ev&2wx)^BW z9da0~zU=SSQ-dxl5+KNtQIVMY$!E{cBD%|SDICAsY*>vi;aj3%g@z$jZv|ZjM8{}x|kMAa%HbElEsEujj>*1ZW^A?cKqmj zd`I|OT*NqPsywMUsvkJZ6HN+qiz;raAZjuf*g+7ObHQhnP316oxHhAXTun(MQY%m+ zwE|KQ%(8?Hhy&7qJfIuU4@3+^4nz$^55x?_nzYqMt&(0%T^0vYm)Qc(Tox5;jvP<$ z2KJrn#4WoY=#=Z{%vLVFSMe=>?(B70%ld}ps*JR!f3mD)#fa+^wn3#*-SJmmGKmTL zp4JlHdRyglzmEvN80TrKtQeN7GuO=7`K-_8uU_5z^+V$7DWM2Ak`4BNTq$Ovt#2h>+PxQv-M#Sf*$Hpgms^jE* z&zv~fk^PGDkxlvQIglMGO{g|CEWyrvBsp>ZEzS!#vzJ*O$U4WksK}WR3b!4YCu_U1 zG2g=ya5Xt0G{NrU`<;0hf*H?)6-^T)!BE}syJgF+TE2Yw@2=nWJA7TWY}xNt`TZp& zvr=|!Z>&x#4sUw2EUF|mZa*d6kKn(ltEsN}X?ORdIKbaeq{d~-mcOUn$~)P1{d>!o zEmKzQPf1Bn9qw3GzStZxEBC;T+1bJu!iLAHYpWmaUG>O9-p#^CR`ouL6NnIl^oxLp zizlZ0eIXV?EgOvM?Zflv2627ZaNbblyrHCpI#*?!g?L<^S#h2Wm0m~lAfuRc(2nC5 z#?RRPs+_TbQV4B=N{*we#yOl$aOc@f%RNay*za#75o<13p3}8%?W)4gwBogSKl#mX zep1~38+@ENWDGSlrjG`mN0^cYU#r;T&8l(hfNHAFvtO@o6XZE;q z_FZjSf-)EQ!!q&2%%hl)IW(*|AHg?EVEE*Mfmfk$vS;bPe}7%w#(Ud#KY*P_AAUG- zgg$u*ibtsvDt0LI=`VK>if7!NQ~g3lGM~f~+O+awPI|Svm?u!R?CKTO#ZY)`Gc8vZ zyv)ms;b-lWQ28(Cg7Z4k<+ovnEK23^z!mJ3U=lADe~&--4Jw5jwd4HZq9|WBVF06= zn7d-rNhH!{)GAn+s6NgNPgGN%qJ}4^>G>WUMBYCBT+n6ba?dLJKg<2IocraMUjn_x zOJ9mNNoLsWdH#5d%ZTa^vq)+ja)_}8+bBU|GoHgF=nWDQa~7BSJQHnF!rkO9ClUx8 z%p6qbhw1V|;Z%frS#ohgA*vr5g}cZ1-u1BZ@?-SVi9voy%MU45c8cb1d*aXUeWo0{ z;qlMj!&>TEUzK7Q`EXJ1g$7a+Qpq=7NwLc**2;2Wt{SgR=K(vw5E zwsSbuP@a3c{3#{HVS(&da0hj=E*TB*ga}4AI~rzfyT4%kg5I!dapU-d{RigWx9d%# zF(f3Sz7V_oM*g*A-)?r=QCG0#`$cqB>0CTI_3DYo;urpZ?R|N86jk>2y;arw-kqe= zNjiJe*|*M~4m1hb1B69HWRp!?5LrUN1q23xun8z2B7=+q!yw}@h>i>5h&T$$FvzGQ ziwruBiV>CJ$4FB7-g~P%35(y%^LxJM`-_I#RjKN#x^?T;Ip?1Hp7(hFO1D0_a(zYL zoiolA-;vRK<-ld<$F0~NphrJog8aVP6P83j5!E={t_@I9agvk2pVbJknJJmx~SEdB^Mf%;Esh8 zIZb(G^_9iN<2nlKbNmgJMa3i6XD*+xX7}FKTbBfiR^HmW@A=gu9}}8q-rhWV%=G*2 zcxVV)PNuo{O#18(d;T%*o;xRf`MXz7Pli0gC=R1G3HM+jX@M|sO4fo~(pU>|gn(Zo zxFz9|29G7kCBglZef|dYk`!+VC?+?`lfIQFu?3?8Qc3dW^YUgo?mQiL!?Y121! zKznst8?)B=U38zji*=}0r`8H)M7Q&Eqrtn+t&k5PCM(EcB%JGTvxZtcUKR?%86nZbaHpY2K5SFwGb1fVgu%GtJYu-cpBPg` zCSh6={zp%oE7A`61*nd}OlbrGi3T6wGbH0N!J zn3cgWm$|k%Y_NMB3cl;*@QOu1dL;Zpt?pMoc#?A=O<0HC6J~UWr)M=K*ESjp9;_~H zwA>*NRU12o$K=@iRNp^C*wKDDDM1?@V>F$1Ml=i=I4~z$2HBuMR(F0W^;1=2{GJNN zyC~vKz~IgsuC^pZTf!epGbTrh1n)HqELN_Rbc;A{ENce_r1^_xkHt^I2!E^4fwut-=p{`VCV zW~}k22kr%G=X?2ix%!LW9ip0Bzn%GzeDP@W9L&Mt8O@U$!6eF<`qBasYUn@BYTX)X zwO~Zo!w^TSXEZPVgIw*M1f*4wtF!>G0cGz(fiOk3iw8R9&^P6BVPku?P$H%-KhY82 z{*U8}asCZBe+ka7A>ap7(KX^~q6G>_%2z|rL&BjEPM(MJ2K=-9pH$LGh11z&mgzyKE|sJ>yh2n;gg4R?0}l=0 z%AbGE1}IQ^d1zkd&}Z!ni%01dibcqbzXE>QqylO4*4%1WqBUcD(ZK1kanW*{d~U1M zc&y{Q`F#Z8HIp$hK7QEnBw=d%BJsgvs8g-HOj-<1;Z)Xg$&ZuRCrporY1XEB6C`~> zWFbTlBNE^(hMR0Z0@AkgIjTHIVUe9ZP56#jU&OzpM8I7H;H20F#YjcprBf!^CDHoV zljB+%%d>hLF!LQfE*$(+sovs0%(-JW$X=?A?ZUjJ4fF~kX_ZKieNrMia8R$zA%ub`|rOvsL33H8^bJLA9-8)zP zaM;|)hoUR86ClphRLL|mgGjNqtn_T17-kf0&d6k)%^I6*)nzN{i78<|>f<9sWyAs) zOZ)jFaL-_D7@{p?Z7+7Qg%$dI$_RwHVidKE)=-5UXqcMQBuLufM;%!Y4!mdHnLjTE z8AM%m$=V?aO{@Ao{;XF1(*w<=8MoXY)^S*PA*rKDS|JC97ZyA)`H3w_$cd1WmeOl? zOw3)QUxcW*xReA|Idy9H0b@>^$D`EQ-w zu}yd(p`%H>{27hhvF@z=)ebN?4?VE5;g$n(@lN!j5zwbCs=e@lR|k^aHsbt+W`T(; zinYKVCGj*$f^fBFgt;@K!qW9o=~6tenDuk~GLtDbidaJ1+~)rF@?exWrtN;H)gSrzC0{8Hym$KepU3%1KA%#%f0;Hh7%lOYEb{ zM^*=JPxn;ij_Kc6=QIKg6k+k@u^~>RDk0Hn@t0>sr{oq^s#K8?PD@suDl4l$ZxDo+ zq9X<$m*TD9{gTO8?hQSk$G}zG0`BgXc((k1w_Z`S3H!bdQOH3s{ke~#KT=`^ksukq zGN0d9zJ+cPwusMVZ^_w`yCv_a;b_EB=h4WcjTVKnB&RILpHr@8(5oVJdPOxcRuIKg zVWBDn8U+;=L%c&U@NYoK^zp#i|`AVps zV&Y>R%@{Q9(N=pR`=rd-VC}#NgEmmp$fqjaY(5$mF7K6p7`MLsP_sD0)yF$$J!qa{ z-9Ma?eOY&x(;E6%UfwHn-p!p-Cch$2%k#b7A`Xj*K7Se-e?;dO;x3Ha+?df^5@;kM z6=|I59RhAzx!uyQ2{hqy`DJ-%4WRjee`6D!wE!KF%GD=??G? z#kwM_x>%ZE(ODuer+FT3MW(V8k&3Jy=dGvzJIYC@5llG;`w~naMW=v)vdF`NCk9i! z+jiUNyDZB&*JS?0F0RRFS}Omm5U7=Y8^^3{8fAK*FQc23FZQ6D{2o-B7{4Q?qGyg0 ze&@hsf%1p3ZZg6d9WJawk`g!#w1h!`;Vxk562MIWGZy5jc&I_intd^tqNE$47IND& zXDMd@!z2ZA0{yF)>Ouc?2{}rVq*rJ(sJ~XxiSkpBqQmLknEze~#vvE-uGHc}B1lMy zNo{Rc=DiOh?Fy&22YF~)`}^WTu#RLf%OV$+#X9wVNVJSV6g&VBH3n(DdL8FSV6^>aik{fP=*Za`;A@7@pN)MP)i#UxW7_H(z(S}sQGYb3;uq6! zPlaL)7bq@42fP-_5K@|-I@mM%PJ1K>l+KKHy|<jXb=?f4}PN zm#(PU3-*87QS{;=SJcprVJlbKe6_F8v+}xaWu^=nW?TrT> zLJYza;_Wfsd$S7ejR#D@aId{MHwQpefECirrs5v17N}u{S_l$b;|9C!jT-_OoW2MS zU~t?3+z{G#J-A`)0%{1GIi|X`?poLb+v8{+Q?o=EaTV;LNTn+*r+@#ttP2X^FJjyL zctbjWf>!@TwF)hvCJljJkPLvn5in*U-cgPD3{h0)103NOA5~}!RbU%tAV%KDz@`|Q zKe#rI$U}in!06^d`CGYdHBNisO2R3zp#8A4=cj47+5oab8h{LHEK^Nxz@-xmAYm{A zFeVz=g+vX>R%x;ssX3Yy7gN9z+{eb;B^s4eLyH{BLK=`MANV>`p5+>uEx-9yrrZ)K zCAFP8)ka$v(xt%_Tyrq4IkfwlMwK3yF(WU8s25E}Fdk^LLB}Qj+%+k#=<#}#1?JS2 zMs=LYq!nM&i*#vp$7h+e?^jZi+_F%f#V#3If#!ipCpGf?4;ol>&4Dt87g8vG)nM(` zu#8C>y$Il>4wJ@+=#ogCUJYm=8`_{TC|*yDM#0J#WGrMuPW}QZCLdydFn9>POrf`^ z=aR`M7Ez!S(N0UN<+tSn)LSKgB=4eSwemYGzeK165i)Tcmk~n9XcR05N64(@D38#d zt5F^d{}DoY@I7dG;5JmX&_FEWU_AV4$fIPp0U~9=irL2SQMO^0Fw-zYiJJ_w455gu z3Pn;O9@Hopj8Rcq6|*S2rjF6~Fpml|sq4PG0t&cakPT3{Ck;2v|B1|P&IhGFhcwRD z@y3-8EB!V9vtQVqFTd!gnLhdWfSI>WOU&=ne~9mOMwj^FU)It4Uik1($YUtJKYHQ@ z`T1!hhJr#7&y{f~w!y|UkOG)lF9${#vi#*7WS>>;FK3QU$zjH-37h@-8L4`Tv8B^d zU?dS^on(};&@sx{5M>-+p&6B(dV73S)qp;jCx=tDp}?5uwq}S85l$&9uOTaG0Jk@k zAq@X!)*`0Pd)SI03lY1!*+60OJHHq*+mq8e zc)>E8wS9VizbIX_!|w2vV9gw7w%UBco{BK9BR}Vs+p3S_ISw3Elm`=UP*p?2j?K%d z|B?Ai%l&1&mo0>CCyxl!N6flo#O#>bzJa>5hiV5skXY9juT1CL^fl=nVGqVrt^n{E z67+j;GC+x$gBZ(U=y|<#EcZ&bum_&@|HUx^c}rX@eF4p>LQj|w$kRiZY1Ia`0S1oR zfcLj6_Y4TrS%hPa5p+k?hyYGR(jyNI1BqZ*@VW8`@o3xGOhSm?>}qR6(TxdE>F^!# z?{@i}0%}H%n&ZJ0aWS>fx$*+}du56DZ!K!LFIdB|ft;)Bbaj36VG$9fhMdjaKpC!? z*Dsj(;6K++WbBQA949%%hiORx%b+7?vX$>Y+NBPYe_*L}s99NJ*8EvjsMJ8nwbJ&v`Ssn=P2G2MxnyT#ptJPF>Rk=mkB_euGRvIQh?I0y2lr%z>`9VbAJ>PC*g_0G&o{Cf!RLAcLY%kuhjdr zKt9Zh+$=R*c~RPpHM@LRc$Ry9o8=^Fq#Bq+oINpM1GBbPQsewgA28cBWLZHMGmnu@ zBTSa((fM>fzAwr~*`%7^ezg4^u|)D*`Si+hDHBqiBf2r4t=)WtcY z#Z*&fPFyM+QOW9Xi^(b3(_$lyp#6$4+tn%Y$(UO>mYVsc z8BB;>Gbc`sS1}zm-XP@FTjb=kD`MG%`nrh|>*^<6X5T&TCUb{hd4~^jKjpPaF|$CY(_K4VuDl*;Iu`eH%o+7Z&XJ>Bx2l) zF$^2@^H~md%m2*{<3=@XlDF#?Aq-fQpD@AxO8RR(ZVYenaRhk^f2=5#-Wng|Cwcej zf1g+R*uCWf2?SDd*i?@O>h*3gLFn9If>670mnt{zQgAzngFzJ?`DS&Q)+&|RF>S2X zlaesA-DZ-)K#ApG@hb{o(IDdS8!!_aoX-fwYT)gI+07hMSLvi1KR@>PLK8PUvYsOu zVW00E!SIZG>N`ojybpNB5%S(lTF+69a{6cT!*t%_9F`%({Nm`9AH}a zNRP7xwF=i{E3V4|Cv@%seDF9wvjIq~|Ey8#xX%B7piza5w8STWcVd^EPD}YpC}|3{ z1e4Thm;eXPX9MPOBZ1P)A%5V88_E5FKJ}i4^t!}G(O8rlVFllvqujJqOkbL~*t0aI zcfPo|(y_Eu*O*e5>uRWv$W>c&Np)@!hQ(RAak(kEuI%#%Poj^XZaam-$M6cfL|a~4 z-laB%u~G;KnA3!L(tBiGD*&=b5zjCfd+zvewj+Zn71ll1(z0VmOY?RblUG;k^VQe4 zM{l1!YumP2Ejy??zlLpUkWW81yJh>1SuNYB+gGb>+Af88uY64tW^dcxGW*xtTIM(8 z*}kJsP$LZ?qY0P=py>9rBMQ z_F%mUG2U=-2I@#==_7d_g9kGI9hcB-z}VBQhQweIb-^Gkj`UMV&99HdVp5IM+FV0v z6XLRg+-kyDuo{?iHQ3+v2p5OyrvmqtDCnRgc_mkq8(tf$3G7OeSCb@c`thX~HeA@x zAV_D=GKn}x70ogDF=T5X9!x4ANR3iCBODA_?P!fswHn=4aKUIJoLZe5X5mR#gbEsi zIZwK#8uMwc+Q-bNPUcB6jde))tV&k{AXd?Y;xPjX9aWA zdt5v!``YM3Y&Wu2x;ESp4DAfxrM2kdNF0sR#_0g-@&!HIN(&Uw{f`ZA9MtSuK_{5$c^v&xqtbBN7TE7>(FNmKXI5 zLOQywh0EY=PxdcjaYse{Rr0Lu+h?&-)X1ZZ@I(+X!$4NBRy<(;Q0q;tK+8CEV92)S zi7-0Y_y}(*Ovk^8H8=5K0jv+BLMu-tXnnp8( z46&EGm=w`Mp-}WmxfsJ2Y8o-ASTEFz6;g!?GlP^N2U*h93-B9l+tqqWe&bn%p%gGe z^f`jN-_7qnDPT32^_o^Q{5y--H2Q(aH@WOBuHPRNMrbpyJs_5A`XR7__jo!LxVYs1dQS! z4aBCg3un;umDD@try26-kw}X{FOA=LTsR@e?cNCd0C;{;N6hFUY8Nshnrsf#hgqBi zIos_H(CSzKOmX&Po^s}ctbxH*G$16L5WxtjTnKB9avCwjVNN@3OeBk17NbNbCf6Ae zRgbY}Hp59^Lr9O{9(vXt3dIIl#Q7SO_b7(>3!|Dm_1@T-nog45IkZrtFwe${ytyyk(c< zt->d;FWFlL-x@ly3jPkz=kV8yy=4%jK*}W994LsOJ$H_7=+Fz7B*MNi?{ER*PmR{5A(bq>;nIY$ltM{&@|SMpOalqK?0v4JPj0$_l~ z;pdzdmPTKfsA~Sw?8S6apW~Uw2ZYjDsZMm~s}eSRORMEqzLlqkvRSeD2RsAjg);+* zvmj8DkeFb#u*`o_Jceut%`DU9;aB{YjDQ=ofC%6{gui;dzQRUzVNs2XyD&z74GPw7qQSb9fJ$BBb!yxC_pJD zufduE)N_3#tU;gd1(-k8J3%lj|N0;2*A8!R` zt3nT9Jj!bW{S_W%pcXZZ%bEkL|F2BS?rtV!(uD5@aC zK^-Wq5PpJGvA;xWVZjrVgi*ON(09ONTEX0;!cT4ZZ3|f|4VPFh$((?j<;r5t0p#>C z=osq+{Og#_!;HAvWaQp-#q|c&kGBCVNR)ahEuvH!&Jxw{K!^SV;7;|t^D#fT2E_t$S+fb-%^BDZxWBH&R_<9NFZI~qtJIg_|$+NSgsS7OS%=pa@8_} zT8Ge2K@S3Z$-pysvnhEc8ZJ1A*$x_A8I_weRZm-28b3YkDY@otx1^1ZSH<6$}zYFc?x%2yHIRo9do2 zd~{QFPHU69Zbik4&2#P_GXB%U4Qs37daoHccIvH?eNB-sB`eao!DgRy+lZ+~-T3-P z*M^5}jE)&poms#%X&kZ!w5VBx_XT7D*@Wn0V2`BxpI>pn*M z@~UG#Szo@X<4gWx2tLl3{ZwwF-{MNKMYT`iNs+lJwhF4aip+;#pg^pvgvZz zozVCgVkp$(C;T5UKsx?+y$Zo8rT-}LnZZ^Bna|v~U72N-K6y0@U4{H-56yN`k8_P@ z&5zemjeij2As1KCp|8)J`T7-iPp+8h?4^`xtlG9eBRB8xABDY53~U%{CJCZ7%hMBj}RI>k6m z;YloHNw%FLH(4|gReakud-J$bTX6*|@#UCzHHOn{I(0}o~*IjoyUwvqK?-BCL z$;s5%rhYZOA>nm4wp@!eab>DY-0B?}uyTX6)wr_IJs}Kiv z2~Slhz$mXDufvQNNpL!wPcR;2!*}kLxGt>iXSU<_ymHrh6C$EXG$>lqMW_%9Wv&e7 zUQn|LH8##or!M)xQPm|G**IA)4{5CGGNjUuK$OL7M+O{?)EaKEx4JYj79iUYMz7Ig z9EAZvmsiT)j+iw3g~yLa8+18gfP{XIfl|;N3Yk2vb5U7> zE-HPr9XH|4;;f1{bWnYo>q@XE73i0`7LN7wO)9W>tloUX(x?TaJpomM$6*Q-Khhc* zooX_dmp;-O0h^TbQ~ZBtHl_4UWKkK;dxCu*fz;*`BL~?V^x?rABuWv5cUSHCf;}dx zW%6J+o>U+FUd={qfOs+g0QXNG4EhHS;#pw$!(5P!bmaP9Kl_ip?C58nVMlMo(KEV^ zR=k_syAVA3AiSFpLfnBcPkwgk&L_Tj5gr8X)~z@iz2~CTB2LAd!;lytNR(JwUQFZ! zeG_c7=m5rls7Ffj(2KLEsu}N_8TQr**joZT4`Tv8gAW8&dLMW<;X~&+v3k@4U9kT^dB@OWClL_Bg+B0==yXh$bO9?AheOc%g7=l#UP&6{$SD%q zCVet+VW=zEi1OO_vuQ>DuLSX!l3d-rZdYwSU53_xp`Np!$q*1*!U0G&lFyqmKp zaFVx&Pmxb>=P+z5-LpzRcwo)l&W$OD)-GAAy5uh^FPy)4@xy2#p%#9UrTl4zy@dB# zP#$NfdC;`*>a|ciym}A?Osk_+FdK#so8@KmV$4+vCKhEQmMmIX;J@hp!cN3_fyGU6 zi0~wf2xG+bFVMg&2Yo_f5~m1DO-s+n%*xKm&GY4hm!P<$w9H@LyHB8RMPYCcR z`i92-0|qt?8a!m^EyHdde%pxKM~)gjX6zkg-1rF-C*3*uuDkEKcglTJ@1Hh(#?0nf zEwkr5@Zdua&z<+k`~?etvFOpoOP01STfSoDs>fEZS^M}C>(+00a^q8*p5FY+EzfNI z)w9oS+rH!1JAbq5`Q5*L;dgs}zxTy`FTMPSS6+SX_5E)gc=L~M9en%HJAZojy~9V| z|KRAKkCDF||M0|LKl=ESzkPc0)af&yp=P zbS_;Zyd#_ve=Qz}?-idDUmCwFAu&;%7@L@$SerP}^WGH!Rt~`#woo-S!h@Yd`_jR5 zG>&~3#~u6H`{W0+UYTb{Ovo{8~ouFV-rFc2;5ru{KUW6lK%~4a_~drDW7ek6~PU= z$gjvR$RhGOS%-`rj{@1Tj66+#O%M-HTFED5Az2H{^arr?tS3vzTd)l;kj-Q#`4Lz9 z7uialC-0JX$Zj%@j3)5#3dOlFc<7_WUrW|IfNA@v}6m^?&Y zCeM(0csh@e`Q#h&E$|{8c)gTQC%FtBqJQI_&yml`NANoRjeJT@k~8FEa+>TRzYqRy zA9;x!#QI+HB6%Cj1>}!pad6*n$cEtB4#wt7o+JR(;PV>)#w$#oQ`X2Df>}ELd7L~U z9mDODPB$n*>5h&^S{W+Ag zShu67QO2T7LFt21gx}|4xf5l0ccDo*<_DBjDCe<#A(of1M3ya*jWQ|tceJvKAT>PE^@tih!gO9^E!N+!x-lvMnV)qORVxF1CP9-~9Cyc?wi1@(t^SFXjbw+@Bf zVd)$Pqr&RQ>esWNeyomNC0MtfZOzwNy?T~?s82MuO~$ox zUu+4j!`q!d1GXM42p%{_x8Uyq_$|)S$=c0`(&KsZKJYHKp}omGlnp4XUbQI4QBI+t zjoAHn?pD@$|6=E0?Grp-=TBJ2by$0M?!*#x=xQtW%;WI)d6c)6Lf*o*wWuH3o)!KK zo3W3zJF5%3hgYx<*P!fp_KaC!f3rI7!f*Fr8N3dE7VNp;nef8esApm42o?6MLIwAV zInrYk?+V4W>3->$fP29F6z^M@x#8`Ld5mM7s1Na=NGPmLSpQ`8Vg2I*)>&Ue-T6JB zkMn-U>fD0gB%t6p8iv2o7QC>&g7<~@SytEJd3oPreTMZhwq)nHh+}cz{2fQT!Qxil z13U-VT*qKX9fLK*`yXZZgtifCnWp6uKZ!8y43T^F2Zk`)3abZN33Dd!n`<$Lt%v^# zc}-wPSm4{V!5i*?J`YFCniC!#7xY&&EMjnc!5_i#J zM4SbbT@E-&@`w+-E(N3z(G10;1X{2R*pG73oAe<8(ieEBO45&1fwis%h>$w?78-yH z=?^siK+;480UtsK9gB&1lLO;9(jqx@)1WorR=)3ozKa5k25C z*Irkkvzb=wq|i6;7Q*5M;z$j91k^~#{B3}3VM0Ceq6Q@s{AXPO_pQ;*Pm|sxBz6*2scP{_Vbu&uT21d76*45!#{J zIohYR`*mfy!}>V=Gx{rr5r$_B=ZvF`ZujC& zBKv0hWk+AfEXVVX<6+vcw6H#5lfqNNUy3kCY<4=Gt0M!ECtcO9_oDKmHbp-dQxel0 z)9HT9{eA3;I8)qn@fKwIa3riu_($TSiJOwjlO9Q0k!(wjO-@fPPOeHGoIED^-sCyS zk0!58-je)$@+-;jB!8HEHn}bNibo5M_e4*&$M3204D*cl-0ykV)9P98`K(uLuVuYt z?=J7Dl#G=2)J2ug7Zex#s&Gc(io)%Mmy2qOW)=Oa z=r2X>#k%5%;@slri$5s7P%^XR@1+AuXO=!wdZBD%+4i!%Wp9>!Q1)rrKg<3F7Hf+? z#-Hjh^jG?u{GL z`VQsu=@x%Q0FE<^Zq!Vnu%NrHfNNI}_iGYkR-;MdG5`W5Rue=f-24Pvz@Pz<=gm)7 z3m9*c~a{B*TI;C*&bbO!B%2yHe$Q^>1qLZQh}rfI=xdtny|U9 qU6zu!##sFSB5}YL;q%Iy<*WJfkL%v+yjymwW`H3G8AU=q-2Vgeno20+KxuvXBLch=7QQh~S3S zDpEv5rIu2pxD>EPt#zvvYpq!2CswO5T1%~Ba(Tbcy)y({`s@Gwyzl3Inas?cd(VB& zbDrlp&vu@3VVp7Mz=zD(>^a$ak8k;^ld*@_ecP?|0u7Z{aCd3wpO>)zm@JW z05=@SsY2Fby4l#$ZwM;NB zo6&!ld4J%Tvm8ro;8!ZESf=z9X^ ztt=<@cY)&&SE^;tq_*~+j^@UuF7L3~bZ=fxPQJIM$2+mPtFx=4zPcsTTiRNi+7;EwDHcX@2K|9sc!A`&T4CI^Gbm-t>W*dJwubKxBE%A6si^O0Y3}T7 zZfo_TeN%l$JqFv@QQg{AUzh1^=%}x!8*7`YI~waVyee1_dwoYIZfL9Ns%~y= zZf!(AwV)cc>}sm_Hng>ZEY-EOZ7uC+P7S)60DXCLZG9_9Ff4H@wMa|{usUybXJ=b& zb2a+&*0t4kx74?GRd*3S4b98zJH5jQqIQFKPFq9Qs_KsV#B>c4NO4D7U3YE02BxkV z{AsS~?yA>tpdK#Vkm+r1tzF(-N0_W??rLi5?gBC`&4G@n2aV&MG{Ejo43vhG>20ak zM%~_Bv%I;pDbqXDM<(@|-PYmltcM_=bu&;64F5Y_(-;93G((30(rF#7YHDlwKCZ-u zhVG75bO?&z#=16dXIrMXv%BW1`r0l!qtkf#^0rkppxU<9x@IC+=V)SR6$VpX)3&l+ z8-p&$8VVN#p|!0Gi~xfOG2)Acnl1zSHE(BAHHKAFAD|l$X>Rq>siBd!wL&sFye(}V znuHKemkiw7)zeqhVf@ocOy`{Q`dT42@Yi?*JVXI!=1@XfHz*g7QX`|QZOr5t^ zcL3||<<%Y9@ayV3n;S8`Kyql;_9h&4Xi{2T3m~0zM-Zb zh{q5#px3&*$J=~~sDlO_^`v$+j?qD<7o;TK1gA(n6S#z#{4gw?SwwV?ABOEjH>p6 zdyN3t8JNeoQoF3WvEGYW3vy`!OAY^f(F(Fw>k5hsO1ge|gHF5YQ@m4Wmsfe`%${0x zc}e9IZ|NLwMdj>yrIV*j_9m9h!SBRO@8zXc(`V1E@}fm$NqN-*@9e4GlJW)KnWg2E zGrd#hS5!`!Gsio-(px&KqO5cZ&Xtx=Dw{jGw0xR(BJL}nUF9t+omE-|pjETATLYj< zr{KP+-dR&BCrt8woe(`Y!sPN-R6I78&18>USupHf*;mg${SF=bLI9e|Fdl~X1G zTeJl2K?$4%q)D^O=S;b5E>56bunRC``V?&(7(faBCTW;y!!O5h2~O4QN)RM~%H^eV zreu0cDof`ON2XTJ2D-#g+(BcU3wokyX?Xx&;t`#rYnMs~TG8DBDo&nKQU-t!lJf7j z)#Pi+>e~8t%(%|rB-fRsrciY)3L}M?sVf6W^|V$@U;UhRi0O&>rI|Wi%U#e1nuh_6 zuPI?tBT$pDO1cuRTUifH*h!inTBD7W%Bp4P>#C|!-?WjNQy8Z>(RCr(fw^sd029k`bucH)z$>D7LD!D+fyAK+}G)>A8bBn}Z* z8?>uLW4*^(+(9@rq6J;=!g(*wv}%&ku0iVz^w0*VUAWeatMqQvT6!TRx~v6Zc4=5p zUxXP+7D24l+Odb{b)7y9I3gJ%Y=+@HQObK!4xVO=T9?e)D0K}JJ?5X4Bzj8pc5Txfmyc(MW^a2oTa4<{x zhvqnqP3K^@Mni%h`wGW*MDdnbY7==Ht^}dFXE1_5p>wi_)R_Q z5*5ViKaV=dM;%*T&Pbw3PhBi^LnB(H(W3>||Mwn(v!MYa>;QdMGV6YPiNn8w=%$p}g$}ASw(|EI40=sCKa)xcELAA(u=&jp)jM9@7xV^$`q78jaKoeEwSuF74;L^cWgxkp7+8oFJZ44>W>{xlFTRNUIaI zy&BD1K{wJbK{|WUNI=&N!tw3H;8xe%=ayW&K0s>WYftn(q*6Q8cEKj@;`*7KDr;$ z7oaV{CcnL0`!y5o%K?it-xM}q>thO_5!Bh}k6_Qj*)n`npVW@-n1nNP@tcmP;oQVP zf91G~#z5_7;awHLv8ev&Ja{7D$W zki_Y7PxKD9)u}-IDc3lA8ThPoM2F|qs4z4Nf_1sZi6MUI93TuyE~v*K&4##7eG<+= zd`Ox}%7T0tq6*DFk}>Luq=0@=4>U(e#)wOFEjT~*K7xFltKA!fO7~qV{Ul{HkAm%j z_x&f`q0=bXH^CknJ4q|iQpb?EtW)EEhdZS0r@+RMwQLXAxK2RPJ>XzGsN4M^Uq`n? z7yF__k)X{SvM51aJq=byx4sv*8#+srrD%xk*HBbPZG-mthobLNw5J>fwY%684tgWH zH>t-;WSMmQ$wMNaUH1ve_tU);-Pa(mT#vFT8qg!vU=%~qA=&0j8n$qLAyr2L=a1& z6l-7RffA#9qM_z1b9PgBE;xxWDvAyCIu~EDBg|uCIMcU3J&e$HD*~lKlTJb)1H+z~LWM_E_ z&OXaicrM$;vjO!Bw9MvjatkkJHR2WMq9bUrmp#WB-^&fGQ)bGW>{)i2y}|mGH zFD;VRNcXVQ@>2c?d(RM#{x-6EKxavIu~$TqT*kg;ucIYnX&AvHqEOkUzks)iy`j7* zjbm#FOJK2GOlITI(#Kvi?lFY&Y~wnmA9thr0L29CsI=bSbxajcJtdxeN<48+{Q8_Y z^7u66$W!9+Y2t96_|;BvC{O&dP8{4Re(_kC@{48Su`qEUOgyTJM;;DQ9yuo-4iWnw zx>?z;iv1_#hxRQ{9=cgPv|ir#V5+ijf!ODlA50Z{Rq;Tc*y9#I+dWPBnJRvE^!)4o z^YZTdOO)Ny#Qh~=*L``)u4UrBJaMloetJ&ab58t36?ePDT`6K`q_|xbx2fV*RqRm3 z_Iii1eXY1-w%quXvPBg)ZeFb1_>{PDy}bE` z6lL>bvDq)*kRmo+Z&x-&iR%=v4#2P?c zlP9i5gRApIPo!9l6RYdQDpjmhMOSBt(itK;R%9t1s#uXF+Htjgt!RrBtu0R}t*U5Q zzF28_O0=w(mp7*<%NL8~etFq4aTR`C^^|D#pHC4@xTmR3G~%nVPBfsWhImo$5Ou1k zRYi>|s@IC8s#pSfxguOyq>3xT#lk$XV1!Fq;1TmZ;&SFvE?338JTX@lRdcLLl|#(2 ziptA8O65**S%pKn%p)osVzw&EXVod?JH@OzQKpKSs+dt4rp(wWO2fqTb7I;#F?Fq& zGC53{vQ|tE6O$rENvN2RC&oL)xUr$iI8}@tV^zk6iZNC(x;R1^y;BsAvMR+9qIkVL z$|^?r<)V?1N>Py*3FJmbio$|OrEsPw$PZTvB1L|<$jgmX^6Eq`F6Tyyoa{)yN6DEi zvLi(nPG!Z55t&Y9giDM#D*63pIWxnqWI9FWQHkMK#_&)j!!9z8@)P(q++b0Lhl=4x z`Fj85a{5d$%r4SqiqzytB{f;3;45XONCs(=BSliUNQ@0v67z)5TcG&H3op)l3q(Rp zxRMYp;_(%)ia0ch%M-ETA|^UaiNP1m4YM2_M6`}ml*z6{IYkuVbh#WEE+S?M z55ReL3U`qRFA`xqUI{xVTzSIj$Wxr>gacO{dBPq#U$L(hq4*U#UxWZmNW8FF?TRg4 zSna}s^CqKBG1-MlAE6N=G}?rbMrf7|idivOgyAUnAC?ufP>youkCNq`LP#Nsh{vbk zfWhMha|wQw*KOLyGyZ@5kNtm$UEC3aA`94nOt0ghlu}xE(0|!{@9!4)Mr3~Hr`KWh z9%K~%CUvLWr0it^Rb0`2n|zEJj&YMxBgrhg_her#bDZou*_RXM^f^;} zPG6JE20BH|z=!HiW9Zjkb{NuOr9J>4SRlYKvp9c1PqmRTR;v)?jVPsVRrOw18gKTn~ zeEHweniH?l$gt?p!duWKwVm9e~i8h3L(NP4UJoe<+u>)i2vp26V4}FUKuzZp4 zPQu$KlERYcUFg%^94Dn`uY76A`_<2UHRBakUGnadSMYv~%QN2Lt|i?4$_${S-o#g` zH@&64^Om}mchmbVp7Iu7IruB}9hBU$z3LnCWLRDU@?6=h!k@v6k?C@HO7bvMQ$l=r zSOjnK#fN4)lI2XntYI-?m^W0g_z1f&<~UA9jD0yGZ=m;O$H1$-gn#ezdHs2RdfxFo zeL5qGLA8-13ky<((_nCidoY01)HJ8Z6X8rvEi4#WRG1&3|DcoZaD!1gGGXeJSH@46 z@X|JZ`LV{vXXZY4;^il{@o7J)7=QN_&%OBeVacKX(L8(H_}P2}k1nS_-WYZNt6$-SgHAcMb2(uJBlGiUJV}YEJdsA8pGRciJc27fa?SVTrcF;hwQ19n zd_r+WMe*p_73yzfSNgXf^Ov5u;rgeazW#WF;Yn)x1h>x~J$m-+ z(Zv;m6@1T9b;)gX;rgeZ;EoDhs3PW{sZ|9cu2$9DE6>_p~NM@(uWNnmOgAm zrj(Tt8yB0GUr;!*$dEfKE-p4@RK~EBI3lrlD!#O zQAu&$SeH4AjdDeCn>XE+Y|7#`L$TvjZ{I*K#G&5_>fogl3522f_*MT`{g8|RP@XFjxUbNzxC~TUrFy|tSY_wp%5Dvp*F@j^oFGC z4d)Tg>SQ>rn8&0ppm(4wBq$19Ngx2=>(npBy#^O%S-d~gfEX$idP~5qwuC~c^7=q9 z+&a*g!wr%<+!c|ODis#Eip0IwuU~)tnfveg=`MrobJhR;U)6D6e8ivm`^Ws*GX%E~ za4UmwjRe=ottKXOE8q_F<_*Ek_qg2Qk}+wdtFS=gg=cpC^q%|A0J_0-MjiL@-_;2p zeZimo>-+o!>PCB{Vz~+u`_;;RI_T$*fqqx1r-cC#i^3xO7Qt2- zgv>3>04sEgU=3(C1ZtPR!i#(VT+7?kf2bSyI@~#eKP~o3??Hz;9tZC^3$XvBZg%(x zY1QBs={@ybw0#DuHWa;}?Gd(0LJw#RW0wtn!$9$8_$>8TfPE`Qx#Ijpd8uZPJbtqT z!QxC3Xx@905F+71G$}T|JJA2G^5!=!fVl?qdmgw&dM$}3`y++fwc2M}9nVs-+~nX^!1CtuC+e~B2DXG_^4Th3Op4cW$QQ?@zVl5L&9Ch!T; z1TjILpiD4KFitQ{Fi)^du+C<)`Ali1m?_UR%{0%n%(hlZRia9+P$~=+#wt^lxyn+9 zsILyASZY{mtTWY_>n!)P`}zIS{o;Q4e$)Nt`z`ldf5CpiAC(>zkIIjl9yLE|`Gxg_ za>8)J2;<7nOXtOT`Mh%8aNc;{bl!a4a^70?V~8GS$N6#TxHv8!SB@Kw8;_fgn~z(L zTTieP{DgEuoRD?ECrl^ICoCtd$&2}7evuXqOEfqgq@kUTRPJ!)=fOlvNr@8gn_f^j zeR^TR^lKWHENN(5vSjeUSO5O{tFONP_gB*2^()h)iRaYM)c$klxQmCK8~i7~o^MpI zRoAH3sMqq1n4yTancN0`T3E8*C05JQYNgJ|R+~)*7*cKpV|xe4c=qL;)jS`cQ_)-> zr|)S#Lw$u8@;E+YU>29fi)Gw0#wM-bx!_v~(df`f&3(e>gs%tF0flu$-OPKUdEwr@>W6~| z-WjVxaieJ=hcp$@YNyGYE~E0VT?zV#3P)R z5atMQyjPp}L^O?LYA;X-qt1w@%pJ}yp%PK?8IdvAn_QXoS01jusj5qR8|M6C{=IvC zcEjxZFH_!B2h>kPL)4Go|5W|l>*bd8^iAu!x1~|0X5;zOat*RCR+h{P{qbRJjmNMi zHsoqsk7G?Dc$;D~gQa0k;YhHhkX9P#Bjpz0=bwn17rRZm-8T}R;HH%1m7EUd%kxMZ zm)6%WUE0{llV;yKY4<~N_HDJlKlShT)zAOUvv}6jJEgv@*Kgdqb>qgHrRUYNBSyUS z$C8rspM0zK@m78}P1Sgk#m(Sk5ol=uu2G6h5|VJqG>eko~Eg1!+= zNzH|Z%L$(;Ea-BAjZ#zX)mPWnuDM!$X2r@c|M2>kU2WIgtbX!$^_KhUFP~puKYtz) zb88zLuU%i?xOQ#YLp@La`OiV-V*EfK(ZRg*X%asqX zepMrW)eEQBRGLp0W6zEV^N)N}{o~X-dC`^i^;d%B;XEWO z^UagQPv~CtcC}eutFDcg`hy%tkf_^TISqW!qD^TPlUErOZjl*+J4`}SyNEUeVPen@ z!xqbFfcQAUCYX5l8sfHuZJNKNh# z-t%Q20s8hmDf~0(@TcF!#-PBXQ)F(09|{=2W^CUDY{CjTp`(EiF=E#_b!nek{SA)+ zCV$5)N{6HiNX82PC@ZvIe4L3J&GGSZDar9>gKUWllUZ0pxT7hel}T~YA!g3vqkSP3 z&O$uVVKV0mOVQ|g5-OgeDa|P12z+{(tfS*O%)miLTwC2V7-~Vm$lKGPnol$0h-+E8&&E*TmRb)(>JZ&nsjVgZn z!Lp5u=1r^`XO0ZTI1TDE@@AzIx~+gM_U8`ENREy`L|~375Z6SQudzATrX^pK5wSM@ znvC4Sv|%=8hzMs9(IFAGa9@Nis}Kf%08=4Pj~F%5Vvab}-oajNe(RQ)j4>|=ggcll zi1`E4g_K|ff=L8Nm^CzyB5=h^KYV#Ew|J#t!Gikw1q&LU>`iT)zW2r7JveQ7;+;4B zLH&m33|8!%vgoqoE$SY1DPPG8{xT@}R;*vYqGSDf_0N@sxqZKV=F{Bl^c(L`Z&Tk< zUs3PO&OTUF#Q(@|<{SCz>Ng)?{1inW)a;&xJ?$R@`GKyK6xpaCcL%|-AjK!a5?ai{ zV!{s?L}L@b7WPmvn~Vl68D&;tERj~n**-n(ab}<|Xbuto;m={xtRh)P`l+9RJ2La2 zxoYM?OVt(gf5WWjPoQrrUj9+eqEQR{nRc35QV!3Na*R19Bja{S78bdXkCsLo3r(H; z8fiV>E*<7iNui6`VlJSx$?6K9)U=gHs3&+czg>NMk=ngbeOrEE@IJBPTn1mEZih^- z#i%zcZ!r^MA}<^7PmW?u7ITxUjyGA>CqyX;VNR<_GO$p)N3qAoo0;7e=cAb%a94E0 zuemE=Y|v8?!Gjc7v!Du>eLj9q@3s{yZ|v=Dzp}bjP2i`$`SyAs+NVxk zx~k_YX{!2Q#iB)XKK;$pJNAS)dk_Bkw?u%uVR4Ev52IL?KRRjyL*y<(HrU!6?Pdh< z(P2ItOEAPn6K(;;tUClb6mSQ`C=hB>BuWA%7f-!sF7)qj`FNf+_uk26+spPm_~0IV zWh5u_Tli|;!*5AWR*z0CQO^$!sOL+jl5W}pnvsV@G#lo3vvzYGZ+Dm^hlMG=ka%V{ zC%S;f00qBVCI#ftX#-C@iTiY9eEeX=V|U!~n7W0Jh1s5{9)oc9$}bH}c!wLg@)vGV zA5gp0PW5Lr`u*s02KuzJ;r<9yyFqT3>MZSs^~{(gSb|xx^H`h4ma%7`RL*D&$?=gF z6nM!q29}6DgPWuYgU?87G%x2E=uSH;j{x?3z&5iKe>ecMc2k|S-XM}#g2L^_Sc?W& zgG(g6U{;(yc|HJ696YAJE%wN-V*~?(L>R#A2Dh#Px8m3wzmIVx#>Cr2OuNao!P(|+ z4{bGd#3O;@l;b0P);M_X$gfbe5O9^$lX})E$L~sz62x|CyO8Y=d%Lj9GKD!#qzj#) z{35<)aoAU<##hnwd;ap=SGv`|s=a&yAF=SUvhhD#x_{s9pJYwup*-&E!K%`k{C3_+ z?9I8{O9o zPgS&p5MMEd7qu}|`}0jm_8JrzA*^R0Q*9Cwe!|U^v8It?!jT}-A%!i= z22R9_(}?Fd5m1jvpaeWlT{S{G>R|&ZO7cIQP-OTsI(^+B?5n(7P3Ir0N7Y>$HR>Lc z$_Eb*tde%`Qw_lFG;mu7+_0n9ZxbLdlk9Q~i#0&JC@FEKFDG9c>}j4Rty139LQdQ_ z5BFh4U@!8o{Fx@;Zv_4pE^)IY@f3>@X+;x8VuhZ^ii2V?q{#75|FIz?wtCE#4N>U5 zkoqINP6G+XK!>)QIbZCrw43ba7%4$Ym&QqycGxVfmwsXVg$1#_B{Y?LdAi6JMLdU( z5);HGzMkJCwu{Z?_2wP?esPECr{=xhq1xVY^Wyl8xJEd*kR$-*8Fj9S{&+*5?FXIxz-4q&N9XQF2QmUL_ zOl5I2<2CgKs$pah7A>Wzk7+^Tq0R6q7W-`ukjUWXoB0-ltYN~5y!cqf$MM~e)92JB z>HrA+tUL~QjQjRkXwOB^4BcAffUJ%`%+L-6YHxLSM4ElBc;U09MQWYvx`4FJC20&6 z(4Jla&sh<7EKe&yD{6m%aI)0^EV0*5^Tj+-?h zg^NsBJQh%djk#ldws^PCkftd`^d86wkmh}kG8^zHlnWM(Oo?QSFkVa~X-8<7Sv{}* zJ4lvmS3miC^_u{-B81>K@@p@U|%-m*G-_%>zEVaz_r0Y63aS9*@`5h zz+4t72AO$;>}j_^mDkx&Kp})HF2Z7v?a@{_+UH7eTkRof8Jg?)`S>;MZGw znwzeco-vm!8T^R%IAR|jJfyt&^55<`B3abtD_dHYK<+78rA%TPYxj@$xTT2jG?o@> zcQ{>2NEnJRQo?XTw#09UYxA{7TQ->6LfQ?j(H+Cm!opdy!#ph66OrKX#EHaVdI)<4 zW72GUFt&$E4JxyX6aN?$MY744X8Ex=^xfo58du-j#pMqgU#-8gcj>Z@IoGc{{D}H5 z^~<*RnpVEMyk&JonY4ZGQ@dXJI6F&yf6~->72_|%a{>Oc?|`sVeTj3bbm#{Z4oq$W&oT zz|d~*u<$yU8Ky*n64#v@nxHUL+Vs$jl^&Wy12`m~SGtO);aLD3Jnc*MtopBiN@?P; z0aN?Bb?xHoflBocNLA3IFjz6Ly&Juu4#%H@1sud7@UbOaf%i>*cM4N@oq&6dSW=2n zB8@@s8fxhh;}P(!1KuWp1!G+E($arA}qFVKcu`x=Gw1-=J(UY&N-}k)5y&`7jT{XT>_H)XyHdU;P|<`Ka{V;23%OxeVbL_yXgN!FZ2g=vMZKf0Cg1hfClA28VbACkgN{g2B>)Yp(mIHSJCkEru_E_ZMz&sFF1e$^#?g;k3b z{>~u$QTXnnwSYAHKmYIG{6<0oB@Q<&WvVl1_k0+irs%y1j9791yjL< z$RZJCZsXN_&12aw%^z4bcvvbU>7rcs7Es&FM){)!M2UQl6jM90bL|Q|4lc(t1KDCC z;)OusBDEPv(IJ=3eOttrgJsfhzx_nIe-P9E>_Cz_a8|sFe)vADrR~95xREmT@^yx8 z={nX0xs*6;0cDK(94GJ(6Pm0(+v2zQL0pGTZS8!-)5Yv=a za9-Bd_-F+OBjx47_1*x=7`|ySP)>+vqxTH0cdy?euH)T`*1KfF_^5Afu{qE)Mv@QL zUSz29mtPvfzy9knWgqoiEcOSqL?l+TuyRyq6kIV<*TDMh%TNVc-$`8hfIt4F`djtc zFZttefZpIE)HftlXn>_^96}VzDA^xp*P$9h%6=I)Q<}`}E0kY{H~7x6W7P5mxnCME zG@xY`RzNq(`XIHAa+n^fhiaj^tO=;ho%ya4vLxXxFUrknj3G``|yawwe zDQuHJ+iYM_2@#<-gOxQ#7#f`kP2QVg8OP?zGav(dUMx{*}hP6XRY5 zzFS!=8|ja;*+pcOSv1+rP3{i+mYA+6=5ggk+6C>^<}H**@Yq<9q42-TBLpfSisY0TkJP~N zJjGMFSoqK!|4%Bn-*eCQxpzz~&dA`ScsR0)#lthzvqfW$?B9R57!OR6*h1hj1}Hgn z`mpFwC0s-|g@!koIzqSbE)fAIOUiRX+Y^0=Lf@kgG>lKnpJCwu84VA=C_OGBc(Qsb z`_B3kC*OKu;dXUbkX+&!Y0fu&`>Jbr0gvRdJZG_L4-ky-BL93X{jTZ@Jd zr>Yn%MUIENa(31A*NvXQo4Z!6Spj}N1}#c-3}XfUXl8X7#dhx49@=H*I}~RqQf178 zb@cGS@;PD|O>rYL*^jj<$e0_sV~viKWzEMz6;>8Lprv`_q`u&e{b&C1;lynDw>75+ zHi&hn%YT3G=^Rk0Mx8HDhZI?{(pTyq79C}aGpD8rb5mT{Ru@FdE}D|Ir0uZZ8ke35 zNw?*>3?6Sf7W(>-6eUh#l}{6OS~}3DG9hzOW|V6oITa9rPK6h9Iie6nQyq&Jtyr;W zaR*QNr~3J#!;9w}xZ;|X8Mic?_@DndwsdC(Pmw0>eEjfTcOQOSeOUeH=P|LguF!o= zPenP;MD%9iqZU?fr};oxiENF2S^mgSC)Ospp~<<$)`bYz!-_~36$U~fP;M+TOXTu7 zfh?$|<4fezR@*#sw)*ar@`{D(yF4jj=T-Obk=`0immcY9+O~FZogsX1@8X6xKs|IU zZ!>Iw<)bx5x6NYO&UP52?UqhiSh+`G79+|$#$r))ERsUmeYA$`cr{1MlfttL)%0#C z3k~R9TJ3`l$0w!B-<2lwKhq%?z=`skb9LhX)Gu3|dq0&P$aJp)8yh^VB1yo!bDlX;Swt3^P+hNmM@mN458pno9L8sa$=Br(_Jgb-ML>QFZzyJ})4@kAeQk_xgQ7uS(I= zCp%ad@+T;$Gnl!@ki`lqe}dIk-I44&69_qi{^G?6lgCg>zLeL(^*NzFt-eyHzGDa< zc#W@BmkdsnY)e%<7*3BBrlRijW&$4k9H=(7Sn=3KT()OZS3E^8rzShWyl)^SKz({S#qmp zdXqG|C$XfUZ&>7&y^7c1HF`~6v)AIaX1lXJ*%8^1*-_cC*>TzN*$Kf)j|sL3&Izsw zVH3h9xMLQ>LxbkTK82t#Uv!Y~)-Fnid<`>hZTliMFK^gq!}9V{zj!mMb@JqP@x`>s zzrzB@7U{LMRrA&i=1Q-vnOC)TFjrpMHF4Hu7iJge5XN%+Fn^p%thDL1jSFK(>xPwQ1*3YBVkNQ7TKN8!Xc<{j|=&kPI zc0LYuXaB(KSw0SZ?^Nf>tI#*uwPJt5#dd8=Xa~Pl?1+O+%hRmeMV8-jM%RbBF3f>r z5*V{ywUT;?YJ8H+eAdo@Y2!6P)3$5ysKK(ox<-8&CjX53hsFFK7g@H2z-)|0l~}BZ z$H5)3>Hf$Tdq>QzQ9I%^ZzKwr}_OZSI|h6}TWg$q)^J1o$>%<9H0 z)UwSGjgyE2K%g8X6=0@l_3r|iJQ4D`oDH)UZ%vI1)3nT?Rbx8~L`G(2$@tXet%C#d z(#MuI$HkJyhje71$29h!e_V)73biK0o6M5Y5}y#CVz$T@YkY#t-CM(ZBAc8X9+KRY z0{?VayxE!%V`SrFJfTHKPk3VCe@uoDo?5J;=R*SPnTLk?IF=VPyvz$nE!~uEPPe36 z({1S?>7kin+2PslOiy}jdR%&ZdP2H)m@hfajcmW>B)G#9q=*NE>i%S{+I{B-XX;P3RKK{S@v52IF57?4CnvA`jXdr=D<~`;Rgovc zQy<>(^PeXraaJ^XZ1JeEiLTT=H|{x{0NS*H8@b9Z%-3>%q!Nm1{_V`kcj!uyd%De}_qY7k^(cG$=`7r{zv1{!{a=GqKt z5L&Lkkd@IL#njzAW%BIV3&<`e+}XVQ0lry!d$6jf>E>&tjotKOyF%hNyqLSFjqZW!;K;wqq^Ck8Kh+BPs_@j-PH5hs?BF#Qa`zIv-$}}yH6?{d`T?)cDFQjke-2B z1YX>Oaa-A4{)q}Ey^InKd?GJ_03It8Ry4AhE#ME5Gsq&Ck&eQug^ci;?NB7-pm1zJ z>3^=tkPQdo|4vHgkWm}G%Ph+l37c0GquFf5c#V{RF-w$Q0{_6h9@KZ;qds!#9rY2u zOWnxlJ^7TpbnxTBqa0VH=~AS62s;Eh8w3COZj8##R{2YSH?t#`CKNo%)gEeR_7GbL zjzU61aLI;jQ%Z={>|jyR-y7F9RxW`P`xdaKb%SDH z{hf>roL8}(GBz?F$qd<)vC%XFxvp3s{C>s;&MNmkDb@}CN}4s$j8&}P%S%5TT>8$3 z(r)x}P(38a!7EEAu4$TDbM3V?Q=7IQzvJDv?&>_=arayA-hQlV`|A(h5azyd?<+gz z!lr$t#z}7*;*de18uG588gi;T##)v1_6LTzuPF(~*0KQ|#I#$&UaVyx~c zyR3Mz+2pzyc3qPFx)^6yN^DfL$!+IJE}2CqxH;rO)`pvh@xt0@Q3<{-884mJJxEAI zgceEZmG{9>doWh=XQ?`iY)jJNo~G$FYp<=I*4(r6>xWvljUT_Q<)N>4ZlAaPmAyB* z!)|!+^=RFpje8=vGeDd57K$ixD0kZnY1M{aslMJ!3F(F3!;>G z91r?uC3wl$`8Z1TQ3}SH7kVYZmjJzjn>g$uQ>Qzm8mAqCLGPeJ3e|i;S2hLoW1i_RyedDeFY0JHb zkP(E1SY%INUgpaYIdYCS$Jdr{f5I>DdOGZA_|eFxqn?gF9&Ui|Q_{Y6Z`XY5ZL!~hn+y*c` zMK_XKFdK%8*?dE=T!wGR9R5)E%7=!lHowYyQQx_uWgd~oOkgf3uq7DK= z{4+9*I+&GOlxB#+ksX>N#~&>*OH-8G6t*R*gWZmq=gBg999%e%VuS1N=vQfnLof}2 zJUvfBjsFh^ZeQ?db;onJ|6urLh(gu#{XZJQ{SapGE&fk1qdfSJU>3-a^Pl}FYCL1G z>qn6rqMAX|W~2P^vVv0erdVT>XG<*TmLOXko~SGfjG`edJt0UrQb-qQmj~sG-6m|eSB+QU&W7L`qfuosaO3M6s4zv zjb=^$(UC5vaEF?)4u+gcRJ1$Ps<^%BO{0>U@)U3A?Ri^9b&QF0nYip^sd3Snp2DnD zPj<8=JAKR$wc%z^K!EU>_EAzwSho*wK6DF_!^!e#W;aO>;3BXtu36~(a4Ks>nDk>K zmaZxi=8Txcw40YNNS-!)ygS8_oOZLcY<^Nn!4DEa$xp$KIDfIpw_ zRywytsMq`$WuOVP*h|wz^8<4?s6oGfC8#65eE{06t*9*=CBwl7()YeDU;R%VZ!g1#CQagne| zO_Q$9&d$xt%DH;-wqqx@O|Pq&KE1A1`653jd-ddrS7&ACAG>ASGkfZ$Pp_$+HXU_W z>~{49*@iu-(eO8>`cq9?%{?(n6Lz~Goe(QGc_Q6g?6!`?7kh}Mc8y}gcF&HO_Zz%`|Ug)uJ6N@ZKGCC@UI$G zuzJ!h*u24=pWZUATRqXS=32Q>Jv%(tI9R6SWTE53p2 zrNg1W`pHk906)kM*MM>{sEG9%J=|s4Zql{`G)1*KY^%dfp&@2wHHL=S-PjcnNL2Sy zs+u-9>$`XK)rG*;&fp>gu!XB#=%9RsTwZ+Ll&flag?f;m9&ms9{PU+jo^y+GMD0({ z*tFx|Y4s4*`0?`7cv8vNaiHlV=f|ObkoLokXFdK&**U{=tp+AX#N~{XL(&>jhc_gJ zG}s&sV_TCZF~Mt|V2ci$P#i5Lq~=ec)Dm{5J9_)| zf=lw?Xm$qvFnxPTJRJRhqVg8)3N~_*$%&w?Qz_gX*ttqx>xDvJlAyFgeJ&SdOUans z7xubJhN9f+-xcMeI_a9Z*N-fl`%;+sPb;r%m|F7slM4>aox7)WR^^|p(Q0o~^)&w< z4$Qbu%uk*&Y~=i<$x|{eyGdGpIzDc6!OUih(z>mF!TRjHHJ9D~P+Z)H@d?F+Q#%cz zj~rOC)t9%r@|FX%0|ql=yLcV(S_Jkox(wK&5~*)xrM-+mD&TNyh--2WPaFYv{>b&y zOE>0W=Ws#(^`+CVE65uuox_Rz!jX9e*Wpq@K@l!(B+q{;W^OuWE;fev?It9MP%{w9 zPz9lFR6Ti0U!m^JJNq)Nm{6S_y|kJj$tRhPAA9W! z5j zo{^Rl9qHRycqfa_%h*|RC$r5Oo|Y++bFjBv_QmH$P07!QpOQRj+C)SCq%ji>uI%U4 z4;|{i`e_$}6VeJ%h6G~`19}AKK?*&ueyOetjC3TnBDl%=6r`pFYt|zol5jOG3H1;u zdb$;YukZ2E_i3l5N=@tjvT)&|E3UZWFW0X93%(XDT=LPaCYE~<6r6-2PlQ$ zG%&TvBo}FsDoF(8S$~9nuo#q){vL@$MZpz0)yuA`DO@_d=&HPjfB*Z3i<%$*0kT~i zpwF}ewRH!k>hzJL_9w(PU3q0=T>O5g>#3jK`=pa6{}9PG1V}S|dTHtO=|R#!Ycg@W zR?lWbDz?O*Y&Kw@yU}5hU7;bcvTl@aA+c#zrV8^^YsgglROi&N>;bj!O?{q#GH1yk z(X%VGMW~1(sBpd5)=7eaSE2NF-GV>-WZBH_yQ{X{yG?oXgAWFe@yE|&8mlv!td6Vgd%rr{=vEu^7JL$qo=wOtnly=${4ZNkPBEwtUn_j z$JQ@O)1smVI*0g45BET|ilqt*rY7bGGN^1ie?r?+qAjJ-c`Zqe^T8x_z|)kD_VuaV zeSL;p_>Q=<{QOt)M#Tm%cDz3^B;0}mJyd8a1u*VY~S>=bbls^VVgT08Kl_2*-8Kh$BzLr3hPHXNoX?ZVpRba2#98QY!L ziuEC8l+=dUlu(0|;=N(r#f7WXo%9*t`X7Bd(tiD`I93ADM> zjqgGS?K6!iilEJvIEKMCrtxPZ=Z@-Vl0Z=~{ zuinFJipQa{I(B>^H|OVnp$@K756u5y8&wpKAGfFTy(OP-r$XyV6Cdipv9aVxmtk7GYua!;dIjzV2Bl~5z$ua>{0@wQ zl6KHC7ip$2&4%mILR!#wg_4rq%&Ev5Gh@=IQ8j}jXXK2XIjLyWqPs@iTzA`Jhi|(4 zMt{*Qm)~^c=eI7}A$50M(Y@r#j@IgH=FoQ&&t2B={u77(Rw8+8Uh@|(M!qLDnNR>^zeGvev8{A zsz_Oy&m04_VX*sR?CvAOZFqVbi+3eQ4u|7=3Wb^=ASnwRla zu>7y>Vb1dyY0_cK9Mp(QOb83lACdXe=;5OetUd9G`uyhy{`&Vv8#X&;O|RcnHluEn zw6peC6YDx}8=K)@uKor^0Y6u#e)!Ahx$*MPx~@^rzSiA?^(s(#omz(dx!jFnyqjLC4CSPfwno}+CJ%vgdnxfiEE=B--C7x{4 z|Me2X8{dpDVyTCt(CBUX7@pP`gQpRAEg^;oJRQy)66NN**u5b?i!hh5nPD@e=$W1w zk<(*Qn11GD- zU;SW@T=x3l=Nl$S($gWfM6Y+={3NMuV3Sz$I&hkl5e%rxR7$;IZ?+`CXA80&7d^bC!6ggF zpH9`RDjSzI-im7Wm>M^>y{4y)dZMR#^{k2cQ*8s%x-B#LxBNs+#n{rE5#fnhgEw^e zF|*!kxZ|fa<>O~e7&bbd))x2yK~K`8+Shbe=P!Vh;)xBnCYzGN`LG94d3dtvfz;60 z2jccbJrKIr+d4co)+vQ6Y*?Bb_96*S{&3Q0UOowWYESkE2=G~LhvO^#Cuw~_m*Su- z7gEHcQG3W~y-?YzTMK8B0ud6fhL*Zf|^^{+C*Aq|Qcf}Qz+x?|?l>O$=GisQ0 zaIiv-iZ2+IJF0Pa@yIRRH*AW|&GjWd9UFV#*Q$RND#@S|Fusp4zF-D7N_v2K9thd% zc)-{i%cCqTOpc1Mghj|m5|CljrW?3I8G=(NJSHsk$Vy9hU6PDUAq>Kv+qbXx*@yN$ z$Cs7Pom+~xH182<|8L&=>#^Uw`!3&qZA;7AwJj~zLN4@uABT}=oa#@GbFzp>jQc~_ zqw#k5Ys|}|WqYW_F*`hNc64~TCAwVpYA89*;1zgg3ebb>qU1`|_Xp;uO7Ih?7zoc- zf@($XMK{3Y<2!u|`&TdL5ubj>qnEGlSJN*mZ*Oc^QBkR;z0tz$$5Hm$iVdy5JFfnt zu4Os8#6bJAGIab+c8m6SkjmgVVMexwYdwFs&w}VR_O_w z2vdyU7gFPR^*Np7LA94hJ633qI;t-J)~|VfdV}C6w6#AiKR>4+r!arywESrW(+a1J zToAJ$c0t^N_{;MzABlq2aFnxpUMmS(%!fp+5H%>6P=+|J_yRLsE2~b^J`p#K2{h1( ztKoT#r=l|_|9k1>3;g3IjN^aFn=m1dKdX+byK?O6F?nm}H0~UpzOiQaW50j7th}sv z^Nblc`)k%F#cf>l%iH;_mE|+1&73!%mqn~yvSe+<8$0eAGx}`i@T!WciYFd<;@A0$ zmlTcsDlKh%$+(IA>gz=BsPkLpL-HH&L&I1G`Jr(M(V-ccRy?CXmc7xT>EZJ5)c9z* zDK)eydP{0YW=7`l@Cc_jK1pk0OpkEJ854}2q%5Z=B0W>{L%-{V>c)=d5 z+b7+zb$3=a3eo1=HR-Oc(gSL3O!QL^#EpKA|1>J{i3bx4)c(>#kU%~zW5mIpr^}8m zqtdhyBMu>{C$WR)KNR{i7E{=2|JX~P=8&R4%|XVq9R9ENt~@@9^6o#+%mLtd-*$8o!Sb~ z!GP2SoxDM4Xj9t|K?yh&XCsYUZf{yAC8r+>50DS{Z@oRjv zK$VoL6eRN@C!1>^AHp(p;V8sajTO3!+|pUCX`o6{D@b8p%*Uy}1(g}jC&AM_7b#_4 zpj^&Ex|VF=(aeJ!Tg}70OC&@?<^`C>*{c9;Mpj;X;-v-PrOS*vzzf=k;-Nu8u8mZ- z8@HJ$NeW(Nr1k)$l5nH6NDjnF3*iaLdE@{AHrTWfAH9~({i37V@!ccROM4!;_O2oA zPyabBU84G}i0-R{#VnQmI@AY(xx;Gr#(N{}@$p`>Js~l{03F$6C(sVB)g56<5}K}fwqcWKP{3RYMx@kb-<4iD!4(IM@u?QpHyvK|AJe;X`9#2u zLS|C5$03IU5t3Z~%%vTQmnI<~A#$m!Q$aqm4-uBo&hF{dOjQSiqWA;~PoSF%TY|+N z5)9o!%TR^bA{fJpC7 zgb*q`R58bp5e}=Yc!=T5I|@k2)y8r|(H1EZ0nT=d)qspKHpCENg53_`9;FamM93z{0_iYB2cw0)=GJzKi!veA z9EWe*w*&hp3S@`d38w6zm$Ra|e&YKV~0meq{VJM)kT6CVP0O2i134PC$p zx8){Sn_P)L)6;kILuwA%I>YyfqiFTClB(9uRcBFC`T=-FXN>7`f$C?1d=9Jvv%+dA z5fQ` z#m0Odhd}^@kZJrcrNEp5fyO;R61YghKt7L3CI~K9vPKA@v}?KNF#GJhwng3cuk-vi zshhf)cK~R}fd?w?d9b6f1qFEn-^@F~03?h+@+S@I$LdFK0-hl(>1>6hlLQI4m{kK= zCnY&PJr)3JNy!tK=?U}wMaqOo_Ec{AgoN0IQIXS2?D6e*{$NkCiFw-HmBmZw*#adI zUQ~K7iNU}#29y&BG6Hx?dtu2+5^@}12l#=c1IY(c4rCq3HjU&riX(c=vL=FL>Vk_< z^TOOn*{a?$7J^7=!GlA_Je8L-uWH8|Z|oTRV7C9!icL#T72R@6;khpT2XyT^pnn&B zA}oEBm-p|*J&^ml@~Ez5rME)z7@S%&a@51IbI;G4cmDjm$3UeS-=-Xt8faWLV}*Fm z@`Ukue?FN?C<#w$fJfkFzY|8yR=<fT+SkCDvS9U3jqhuH8ij935C_LyDETGnqtVy~!w zn2A~t&RIa`!oAR5TfXT@pK^M?Fs{n@D39d)S0G%Jb!ZqW{3@WO5BU z&W3T|bY2zMTN+L$x-0!t-Mjnqv3d_%Unw)Xl5QFI+w4koL~`*iyFVYJw~di6V?%*A z`X-L({Z0!xnPdhm^sET0#lZ2d3(fl|W!})>?ROr6Hz52*kj4VY&|-BT6?LZ4_sZMK zn>cc*`=nLE$~03=RVsi4OSPwjqJSL)s6ff3K~qhvBe}!ROj$Igj~(x z7gVciGt^x@aCNWTSxLWgIPy+xLU_oBhgo5bfR+NATSk;3*({3Aa zcoiZz*^7x2eFO9Bejl48Odv=|9tW`PADoZKg;Q|!C?kyJsS>XGf+*L*YZ_A;cv zsYi3iURf#6X_n|ma%H%8(X4wYg+;n3ztE-S7dj1YAg7IpigDa+9**3A2;=aWaKD%;fH7+aTv`NLio0!9S^^y#6-#hAx(VS$zt;eamAijLr(yvmzL(DCkfT zD9Ebt=AGGf6tnO6*<&a|KM2Rb0y_R8Lig|lh#H6pY_bV9v-=doyR4b4z>J%p_`iIg z4)Aqp+3U5n_4Tzg*KmJfpWa19<>gm>Yi7?{y?Rz{Jx}P^i@xfs9)Epy?V9>owX1nT zQE%<5HHs(m%6B|@_UbjYv)@=$fF$YYGNkm%~^?P(F~Y6{1?CgV&?DG+f0KXDBp&VJ$ykS4_$ zin2@>?LgVYX5xBnH=fb^cH_z z$wg3n4 zx0d||Z=A;#VKI0%`VAXxfha`xn`6D^hycU|k`y$LASoR}HPzKqaM5r_w5+RuaA+ez zM|Ws9&lzofGSokU0S!iqkgZm$&1$zgtWIl`)n#=%JdS8bj3d?&=kPk>eay#wl27(q z{Wibd@AOCcU4FOUd>&6k!2-{9LXfZAQ z$qAKdy|cqXi#RSb45sMBTe_MTJnKu$aX7no!BHGWE7vd_UVh??p|^#!OlTV`)ZacYqq`FpD%PQ^0H<$&1851dD_W7l$a#fjM!2gVW3 z=?jm+4c|AT?LlD<)|4#X5A=BT>e^YWpYLBn$pj_+4eG2lYi3ai_7mv?7=>!JS}p<& zbF<`-!(xoEZG>9mbTj8j8SI@R!70-4uj+2Fkz^5eM^;lk;4ULm`k-_0fjRl(igO32 zb-A@&hg&A)jk?EXTM^~zkQIMdDegZTktp3nBnm~3I4OE$u33TQ0{GrSL`MvXZnn5U zI#Y|cy>-;cW>~+)C=-Bx5pd{+eyg5)^O?h!R?&OUXH&!q=R0s$lf+#GLiR{|glVIl zCho|HDBKkCljxqXvIE^yQIl1)$%P~3E-Fs%R+!O0t7KI6^aq2zdU`Vp9L^PykrhLW zC!_wBG>cNP<^sEildVV4tkV5Wq(TF4X-%^%ya=&9oS$oC4SV)BG&1EZpZ)dM=sa&c z4DLe6f;Pl2B*HQXUB+mLoNB1T8Vyzo_>&`y4y#XLegLAE!mrpNY(&F7!NvqCRTO2) zq@3pTSdPzA&rRcIp2^)))rX{7$y@!xHtEo{OYc9g{-6c~4t_dXtiYQeP0?JikW!0) zJU1*h)i@WsoRJZ7lv$2}a^;S)nqvr$4X-N&9YD2!kfA9Z;k12HHHrGB8GJXS8cDKQF4UN{1n% zkq+q%k&nUvz0@c{dBkiK1du{F5nAC!K{nafU-RYHBBYB7qfh7**nqW1n2uh`LPshS zXH#uehN*GfgC{0??97rJm8dXBv@InzPu0C%BHjS2{g7dWyu&21Q}|4C;8qIZ?ZK73l}Q;)UDsE(_3S>O3S}TuPEbVyfFYWn#G<74L}xFmLtobAo&sInB=Ol&5WHpxtm zO^-FmIR#_#@B3Bl#K|*kGpmNG=gyx|zvIf`tnR**>W4w@dx@u4@a!@bMtPrq$wMzS zyuChm41av#wdd3`>W93LD`$9|)pn$I=H!oS<~%TyX2^{?ye4(GWX0$Fa4)At{F%AqKGhhw?+ynTY z>E?yNIH?5h zoBeND8l0Q5V~|D3jg{_iTL3*BQRlv%0!` z$Q?an8 zdtUJQL!G+aPH!ME+JMzXh!E$10l9)@awKA7!%_fj%hjR(?HBA{?4xGCcoKD-Z%nvp z9Rd?taDsN>+9?!>?EV5x39@J=E7#7jFKLf6H)>+m@HKVFAk;8D!@LL?gyCy&M#Hzz zd69mGFvM>aJ;nZfAN&B>V*W*Uw!2>E~F4 zm=R-AjJKnJ)rC4|#AU_Um?Kb^RPCRgYN|6=#PKjwJE zAqPx8vnSCRApCH5iQsD*u80ZI$adh0#Kb0p;gZG{BxvyzmYEtX65t}i)ZoGPJni(L zrMH(q+5Z<$2Kd&&>Z8b;=Dc+9fw;w!k)d7o%;3}N(f0cWkEX9T50=kg<_clQ59mF& zZo4xr&7KtX?wt9(2dGW{!jIo}%mSA_1S8 z7CuT6Q81&0I4-)8BGjrBU_~{lRgrY3t-lYA)b(|n4bTt{o6{C$bJ^TBk1g8Pq^&!A z4!h7BZfNjAtR^S-1gi8Qi;D{fZt1WazNQgIbMj3>KILJZ^I%4FqKn z4SLYJa@<$o_rTl>jgcwt2Vemh|I32a3P7|;)i7IU*=g$q*EWd6x9($r2sQ8T~# zs+gbX>;v~%hDej;EqRljV{H_(Qc0_1 zg_SZ)cVh41rLr_JTnC58%^$8)oc6gL^70F`^*TFs?$Wii+b!Kgx0c;@dyk&I zdiN>s+pqtCI|kl)*Py{eh7KEk_lSEcMplj*eJ>j`wrbq?2@~&|^ow6ko>Dz^+VmMU zGiTM#zW-MbJowPVa~`RCbndU`JvM*A!pEO@a?w+ZpI)-`nP-2q?78L7zwp}?FTV8h z%2!@}ZPn|m*VMnU_IK;nzqw)KriQmRzx~edxBOx2yW6(!c<+xp-~V9O?mc@y{OIF- z`#<^gz@HAXKY#X@Lx27Ji^E?YIeP5)iIbRK0BJ(jbP{GyJbM^x{F!(ZUW>6rY6{Kuq>r2M2VN$ZkRQj95yDLE;9bZ2TH>%D+**Kv~&XiO<^_CpIGZi?OR0 zuVOjelgm!dJ2~_OSzp-kX~#z~_T>+T_r$~Ngs%{g$*$5ltZc7sm$kon(-Y-MJc~~8 zvhXj~vDetIffB!+Eo0xZ$Ka2Bg1yMzV5{)ZA7_WzT=onk!}E}$o?{Ex2awIqv6t9d z_9I&RH?+6)>?5`p*qvk8SoSolV*A)Q_96S29bo&}C+t)94@gpfW`Dvu_Z!#*_5)kO z4zbVJU)V(U9Xo?HIwrCE*e}>*_DeQ}tpsY5AW z53()n6*dP?=Mh%NPP6af>Ai**OWPXRC15uE2lxIp`-XiE8^o9F2s_G70H@(NYhZ7M zfABhmY#n3pje7!4-}ThF01*XRm8VY$;jk#r7=w z4OUW{NXOWR3;!C&-=at;t56UV!P2qj2fpKTPykd6Jhp?Z49AmDa#42T?`bFxpdh+} z%|JmuB^!^j7-cTXe3UwrYVG%&elxsT`6rHzDAXQZyBuX9NB{tW)!r|S7T3o$-`bhzZb`qD9cc&UAms?eG_F2 z3bjr5LxsMh^LL@p_jI1F!*@J2{2l6ND^UibQ2RlYt|-*cjriR~>^Gy(IM97lq5Gz` z^?RcJQ=e{D=y%k==0)$HzSsLk{cB#RU(L%3^oPdh85C-JE&irH_e8;S*XIZAA=!!N z&IV}TH(tixiqiaf(m2x?EkU8{>AvhJy|sF|3&%8m^qm)l#)IY_)lq;Fu20lW{n?44 zKPP>x=)P}9p*pCqRHz+12dqac3e8h7cWB(HPc%=r;v79En%~q86}o@4L33I>N2-h3 zp)uC?biA%rX+HLJtzKyS&!IllE#48_BR_%C4+Zl=tfR9-`wik!#XBbEEY(l%2Ih#E zAJh+eZq#>u?$A7=`@*0ktPuKO1!ZSD^F{g4RC_I!{#oQE(vQPmh5{F95%I9Q^4?aHFR{f1d_7SqlCH z3JmV`9BB9RpxVEM&EiGysF%S{UIB-CjjaOJUd`43ujvhNuHV5Hu^t?21KY?p3BEv_ zfVjdI_6Km3cR}s9vmNX`_D4i)z7L+a3w&Y^xZH=}bsvMnX`JnV;A+In4uS7{4lZ*z z%yEu^-<$ydImNybyy$Q2@8GTf05AIvT&}EbAqq_2rha7GvJcoTvx!aiK8`g z@EU>zgpOf=Gy(fOQaB?x!rZxy+buK3*G#;B>cnwV>{G{0zpuJ#?6@g4&<4eFnuh!9sBy6rbAn#p1X`%t6xN=wBZ^s}BLIyHy$|Jt);n zpUH`GZ+V>jfV@Ori}fK_0Znq8VU^)WW4Up*@uVqey4y6@RB!s&^u76B^C?S(Ws~J% zM1DkN#Da*wMYVA9>t5$od=W=TP`20#dw(eVl!T{j_7O;|piJbAWTYbCGj{ z^PuzZQMRasQHNY!*ErX9*CqEz_jB&QdJ;VMcosxkqkBcqi~e&=Ld?*ZZ(?&}C&X@w z%Z*ze_oFw%JKy`Fw=upf{tlnT7voFy<@>t%%6-FpRlaGyhkZ}@miu1!HTd51?e`t_ z{oVJYAFDt41eO$_@{8 zc&WqpdHH$M@)qR1o_8pJPX3em&*!hse=Glw`Jd!}ng4D6g#un+FYpy)6%-eg6-+32 zwlJsg?!wm!KQGEC8dkKVXlKz69kV*l==ey-MIB%0xTfQW#qQ#lihozUrTBkJZZ8>8 z@@&a_K`A&YI5k)oTpD~ixGwmI;GW=T!IQ!7gO@v*I#qT0Ri`CbRlZN>nl6qmUAjEf zWmlIAT?@M2-L;yi6zEca(4rooN?5}gG{OY!V1sf==o2_^nye-e2WdRqcu6_jny%q$ zj=0fnplFJrm$DzLIh1L8X%M?8jWE;_1$i15N>=K_nhBj&qp(?@{CwT*{97PMzx2ciYqHhlzG zywk~?ZJRy<%-1#^`dHAO`JS|4qTT`9GFsE^fTc)!1ydy{~+eg2=%`+te|-kCXP z&iQTUx1JdpXN)=UB{No9k&}0-`r0+dPX7#7=ao&GRoQyz9Rp)855f6J|EikS!>|4R zAY)I@VoX%|*K~MZx%9g<#u8H)<1f{>E?@P#2mX4Nu~fQ$$MTx?R%XN>yLc4mw&hLh z>Yw}G-$pQ&wg}CiH`K1W?alnWr5GQd@aYY8HMJj}IPeVmpF;nU4Y**d7gGVxah#_# ztm?SU^2ObMVC^c70>^@R`mf7_jumEO)qy?+7SHMf$3~XR&IFE4EY!3)aBO8!=DmUA5VM=z#RTKB z8S{6TPXvxR%e5p0jwKdqsSF$o=Ig&M4?0#@lx10b07lGptSDNM2q?XooZH>ztIy^)C8J@h{+^pC7V(b(>(@pQD+)Yh%4X1grPG_Uit*0r_chL&X= zHI2=U&C4;5AGD*M9SwD!`j%!8r^fGZS=EZ})S;sRqc=7B>zYA@AxTrIM^Xj`tM$~h zx3~BkYcQXuw#DDMs;;@Cri0+AZ)~b-_Y9#CwHrJYE%hC1Yuf6PGBija%WW;So&Gv) znA%2gsc~6nN1X-(&Cq{Crl+yl-_%)4kgRR&XlUu|05Gc>0~65<8sFOq!OnIdO6X*I zR@G@(w|0Vy?G2fpfjKg1&YYGuPkSB20lgamY5@J4rY0OQENF%a1EkX?THDaF>YK0< z8|pjTnlT|Lf*WgFJnb!+p7zdVE9(3mbVa9eQ&Y=YLdf6JT-!(lYcC>(RsxxtWi4y! zG#qqs)NMSGfm!F z(*~$Jn`+uL^lR(d8<%5|f#lG!tqnM8)1PY!&9HWDF4@gP82`-U3$X%Td{Mweb+ICM;|8h+t;0au6 z@FbC5ND2@Q+?f?vHOuO-o@m@o@PT-@rlnDvj_$0xtpn@EQ`6dtMOL${35%dbze!NuMLUm24uX})7e}b0C@mdO}8Xzmge7Zw!Ni^R=37FVpNR> z+*^(T+XL$uE&i1?%j-N?wIG)!u+;H?FIqv?YEwaRK~>i^)$6pIKE*S&w4~BgQ98A9 z{)F-=p5h8mS$XNa;>lAcdy*zp;5;eQGrzcUdgP_n=?v$$k( zre{i3S^1QT3QuXdr+9YRtl}xSR$MY^*4)X(CDS|;abHPkrDs<0?BYrcT3M>y8W^g0 z3htZgnLVX^(sYbGVPf&D;>rb?o~gx^B{b$#3_8J6Hle(-c+%Wi6UsehbIZ$0E2dzK z$r!ezxMXTMW|=a33Xs4+lS<1LlowB%UYUuTDseH>Q&~P?@|4*V%4cR0gr$|!r<8lN zF4=$*V|b>_qnj(HPnb2!GqJd`qOyF-gxS;=T|LuEN@o*|=9WyJP+44B;+Z%Fs7#nR zi!K5-P+`)n3B|KBJ(DNQo-mEj2~I-Y0_Y5ogKn5MrDRI^gjt!Min1w_is=A!EH0li z3DBY^Xb(!@Dn^=AT2e7(&RkqTzu**L$n+^19zb9M{+pyhrlDT~bZMN*(sB?a0LuL0 ziYb|%3FXBV#F44xr2v=si8~0#xu7Sy7MBFzB_7c=YP(T7(2MR4P;v5<39~RDgrww~ zeKq--a+|-d6)UbixX5)SsVP)li^51@W$MZRQa!C1%U8dq9b$Q6eQBmn*K+;(K=U)8 z@iiq(Y6NN$R!LXFwQK623EN5YLu<5>Gtz}h9!2Y$@G+{E_)!)lgTUXPB z+XBiFOZ`T*5HyUfZH*XsZChgpREnpj6Xvq5@%Dg8#ta%(H)BAv+zfwPU3)7mR^ytw zrghnvtc~m%!3*tN-_o`!fV!q5{T)R?x1qzcoG1mm*MU)&XE$_ov=-&$tX;b{ds)yG z%Z4gslUNIDW$RcQYh=q=1M7f4I)wRI27dG4cjmHu94$i+51WWS9jqOnHde=K*eaHZ ztHrDt{j+g2fi>aJ!^-=|YS+%{a8DiXS%dFd^!(;H9yU+wQG@;!7`YjDc-U;f){Kvb zl>&k$jJle2qF*^aP59Jk<9gU|j5!>TeskR5sKGIVBWB$+;{QD=gfPqhnhwZwB!<}uomqu*IH&NE3oq51@YO4!ydAT-I zGiD@i5r^xw*1G-~{kVf*SdJdl-l6e`xJFXas*Tnjn4txucA$47TIsVKJqRB^+DYz$ zSafJm&|Cx=Ng4I?YyDQCr#^ac1nRBRhNQxe8A)OY!XYe)P3<2eNt0u`w^kdEaBo5X zMvSN9=Rpfy=>%Gov9MRn^+E^ZKy%4`| z#3(razybFu<)K zU1`2=Y6Q}jG&ZdWqQU^hg6m~~YJ>H_;QI(eTHiXimT7PdmN%UubcM$M=R74`2?w43 ztF&MJoU~SuPXC6fIRDKkK~QkyH4v)j6!DvSkb+tWtW2n15&;m{RpFmz%{xfs7nb$9TMuV zQ}<>XQOm!^X@KK81_P2tn0f%u{}zH9=ee041DFQs->$6*;yKMg7!2kzt%d=uPSo~j zG;apoNWTQ>>_IR63gN0trM?Pu%}jKm4_T2q9O)DqO!>8%oYiU+PWl$>nuI%b9tWu# zyo2<5&|gS`M=^L^>b7PUW*ls5NUms269ziGBnd?4;JRCb*2Y2D1?Q||w`tratf+S@ z{&Y)5tDh_mQJA#N0DXgS2d{k7GU!|(`$aaLydz!q$*z&)+$jG8Q0mxyn;s{=bmDH3 z=fPC|Hp&k8Ekxr1KHf-4!t7sRaHHIju5Hrjr(+XbbwRs9o`k;k$QL09>5jqnSYN4r z_)9gA8k$|VwYqc-XxQM0|9@z$n^)}sR=QtJa;)3O`WxhKI-8{=tpBOKwlc0 zeE1UWY$p1bU@X#nQ&^QY#}tf4qn2Vm8hbXb&cZLvN&V=KNw_i>=X5*`*Cqz$E5Tia z1NEPcPh|koN?ae9^+u>@WPLt@Y&OoyG5+)b%o8wnu{IvTPxDXJ#x2qAqWh)>Af15Y zGTc>;S&K2kT--%xbagI%%h0a^cj<5t{Rr9;^ew>{<=XEwv=an6Cv;j(La#E+O+BUo zu1XCGnu)NZo&;4T+9!Y_bU)2HQ@g6ukZ3|&CRheWp;(IM*5M%f&kKx4GC=sx!XMF= z=vbl6Fa=j<A;<0iDqdv_?qAh)dKKT%YXQG&X98mx?NeFyg&xJs0zXo&3BKvYM4gZBB`qVHn#r+fzW8|(=Oy%F7; z)MF*Gk2?J1A(79n`-J5C>0XNNYmis2N7)n&=#gqLilOL`Z1aurUprtVKY*an=L*{Y zfw3s|qAUn`4m2B4ScisY)2aEdZ0*evBSoqdm$YG=wc2rq230f8YXAj}O0A9TcAN)e z7(G8gI1KRW-|--b%fF*Pd5Z0jAU(!v)F@2;Wj5v_%m`9FUJKG!r$D{dM!rN4N}}U{ z^pUS!q}@B%FD1W;Ja%2C^vnQVqj{ENPRfpT0Gc9}gTJ-fUpD*+-F^>b#j>@TR`Fz> zj9P3DJCDyXe0o@yw3(ge+xZK)c7*lf%6sfhd{@a{*3I_g483q)4*QT%?YoDqXPc$< ztVb$mhk@xk@&#Odhjrm^53aPJ=KC=_#dffVQ8_-vUSO|dB$b6SNt?BYU6Tsg7Z~H1 zG>)y8>M_ecwvXS%F0po*DVMkfy?-SQ!&s*61o-py;Uh%9dp23{Y;HT&M z1>be~)HLy$sfilCspyoSaCuXPpuTkRq=xt#j)>4E62VP-;WkY z_lobi#1U0Ic{p5oQWb~8#S?qQp~u6OL#lXufmL}tTpZje4it&UaPnA@cvKbpziUzU ztKz#Bu}>9`sN&&yPUYb^@lb@=tBMEriU(A&XRo;bJ0Z$$RothF?)ng=TNS%hu~QZI zs$vIPcBtYzA!2*g1ZDeI;vSpmnxCq4)rxIfUsSfKV(Z8*>Er7w!5cgVLcOjT}OEN=D5OH{E~6^n4b z=tZ$GRaE1S>M*guDyo2E)dVpgm5; zRdPZ_cCE()WrqRiuVSE2()RMHR`aNK%CtE#Be6 zlPD4sLY2f?kq|24<19*io`|!EIG-FF6Q;z*iI^}EtrRKIdqq@asuHD&NK=FonJOYw z5w40bhj63StqK>=cd5dOVVx6&W3RAdLc1zLg+mFA79pyzsltlB*1f`_3NuDAtHKl^ zjIu8!OEIcK!L3S>ka2^YC4@srae_08!lMMU2;ReMx9;S_{vZBh{}1Q-zdBVsW6v5C zSxB5^dK@RE)Z*HczByH%pDgfZW!`k^aTq-(S=q^ub)KH<*UPHpSY^RUCGMn1HJy}G zlYjNk8h@3QIkT+FbMoUUlLMnpSvnclDylF6{-ev7ZOY^R!1)IgEWpMi%3< z$saMpN8F^8N;1nid-2L}=D2v};+0&t)9Xz2I=u}t>undYy`QOjjiF!ut<8|ZBn~|; zmckM#%*+<}vVoo=DGF1#!kA)G%m%YjF_?=)rJ;h&G06s#Q3z_}2FYx3T)cek>={?& zXy@qREa!6Xm0Un-RQ_yq41AoCqZcIcd?AwEBHx%S?R{%Y)uFuh^LcM6m-<$#-{p0E zJu0x_<>HutJ=L&@_k}8au8bL(K{6O*6EOKDA#`o*mAqW;OxFIy<`WlAV3bSJF#0g* z`d8R#c0oCfF%nssuOQaSs^ZN`q}yH<9U>X!aA#sdd|YfybYw($nA_!a*h52XRb$WpRs52E{?@~f$vUhR|YP6k@uLa+7_mM<#)?rQv^ z@jwG->DOWQrF2zoIN0#_#)FO5SvqHxs+!KF2C-FrT6C#3{D4}sPks6kbs2w*K9BH{ zef$6z!V=Z@oEULYM1Y8Lafz%{R;-*oyJ^g23lk|=ATl>ubLIH3^b|QVUY3=ia-nJ!1Cg{~ zgsYH*N~1F*3Pgv*88x{B8w#aDo`1^>+fnE3E7!j{=GLDyy!NLzUy6_a;@t@wMkf!w zeb(yjnYVWBIKE}V{nNybzV{}+v*W1x-}N7_o;L0MA0Fl2z*y&gRI_F)|hish6{wa*<94)C%^f@=o<{vdiGYN=)#D z8XDO0P@}~V!i3cl>HvL4LvU~>bRU-_XP7H8IZY~XFt_Zw@|Q7V50=j0Qm?_KzSsAt z`k(i!|9R-gyl5BCk>>Moux79NH<7Q6?eW=JgCQ`s#mWQ*KYIm&8XVp2aydsx>G=_^ za0e56wZThfs%o$LH=Zf^dCvVj`_N13>$}toecxCAM7wK`NHgSNkQgT`@nt$ftW36< zjj|-0M5E%gHClLRjmu=S2(!T{xR995E?dpE5QEEc5o+(3_z>TT>5gl3v zdWrv7ope;4%wLlCsFRP;!7=_4#yzk8O4^UOP+&%@6iwsDFLrIL~=k-NLbtnCI|MM72aahr^zem@F|aATi)QM!EQQ zE{8$jWs=3)_l0!VVf0^y1-lP$2$tguhrBTX7?>zx%@W)PCehuO9cO4c={7T9Ff~h= z%pdC=+skv*3&6;6eWIMK$!em{hHcVwWQhwGXEgm42Vnu31r`gEB6&V{h{~6HkDWH` z`Nt~Ey$l+o1^l;Smvjz$)fXYm34T|)KeonImup}tZX3&Thv!1{p&T7=V64kz5iY)w z>$@MZJESy6dGW6Ck-SaPhTtdy5ZrJ__WRZ0z|#!^$Mxzti>?PlG)Tk00w za<|fL=r(qny3O5|ZtDSdfFFn|xV>)9#V>x4uTFe)7O;-dIa+qWcE(4QGmCP$HwE zW8{cf#b8j13|1vpVWIZbR==x8W`2o>hZ+D8jHbyQF5&>r6&QXp`y_|}<=R=z5eR5? zMc3-epBE&h0+d2t$O6v4thp-vGVa)9hx6C)M4)Gfj z=X+Mi`IBo5b>SKC(=2jEM52euW`|ouyVJ}W1UDcD+?sAW3#lc!C94G8L>8NQlQgd- zV9k>Y2h4gu=+akhcc}lN{=Vs*C20#!FMIaW?(aO}+4tBB>$jA@x;l0JtCcVP{6``& z?C_>Ps+Ut!&y6T}@xjh@NA_;0y>-Zt7rcolAAaOr_~6mtz<5Z41pCnLyM>Do0o#By zj0mwRWRVqEWT+q}D>58wMJ|HnF!~iP=9sM(F3C2NQ2}lSvuuOP|E2Cu>xPzeF1(U{ z;V=zyto38)3+{zO3ddS=M8%B0ZvNr^Kb(Fe;mxUUOzGQ}qDXxP@lJ34VRb*ReVJrN z2GuJ8v4^ejje_SZOtRu(9s!5nQzRQb@qQ!R%4Ly$hva8-9Cb#oCrmIo#w}SmzIlw> z;`R~?;7ty=1rFkZ#sl^2V3;)-0+{474-y)zTkoOym0ODU8PUXR4yG;cRTFAd49tm=arRt6W__t`{Ri_?jMo{$}a*&4Vs=C z%EtISW`CmayCd2hA@gm^9R49SiFL!=@T6_b9c^$Y4eR%XA@!v30QcYDfb8UQO?5zT zSy(hZ}zOcT2Zs~j~^W2_4j}9K_Yl^0#fu6 zcw!*Cr6`h+5V%8D6mUQ&FdqhPkd09JfzagI4Jtz;FY=*Y9wv@DdO!M5So+2)mzI3B zT^UBvL(FKh*3`NP%8Rs2kdm8)akZZaZ_w!X6mhb}wuKoIm`L zpGRc6qH&je!NF7-$;p3X0ac(aJk75g$u(C_=dLKYd(E!rwzWR+jJj@R6Cd*a)1SP0 zaMK;?&;I=GpD*xpn-6!^uRnSlf2ZT_*Y`DU>fygm+uisq=g;1E-)}M!j%>Z4{^ji- z9l0VceSCwz?Zn1~O)#HqJTRIS;CQ|-Ho$Hhm<{IF3<19xI1PU5%qIP&+qU=LAYKo4 z^d+vzp$qYj4tr2RNJfK^0munG`#?U9nc8_fwt~DAVf`;(tF2#y`XnYubir0 zP)Dm5Krwhmm^WRE^Q(Q?CI?0K4g=HGsO94FJHWT zMw0|Y`B*CbI;r1Ako_VM$bo`JO6GguM5&J)_%UD!I8sRXA~8?i-%facYa#7kp9^Y{ zGexX5tTA$lMabbs_|kdAuxnS~YMP~RUclvby(dKZ*PqB<@rrszeeF4Z=m8Lo2Vpsi{fKIRztL%B{=+co8MiNP~q_;#>ar#oSDrIZ*+p$6=6@1y!Ipn zu9qF}V;Les)!2Xa3-#hv$LpHm*7z_W0jlf zR)6X1jVY_%s(a*>nmZdS$J)O*Kl~lOd*8x4mn@v#GHOQow23c`9`(egC671Fn_53l z{TpR#uKz}TO+Kx3LZ|pxi?1Mi_|O<%Y@{L7#tgSbvfFIVtf99JkM!O)yl8@NTx^I< z$e}S=*>Zw8Dl8##Tv&S4xDgW|Ruo@C$52*63v{$A>e)+Y>8fU4v~WGwXMTV`Ang@< zWf^W@Fh+-}R+0-fFHl!Qk?;gHlx1=N9nef83nS6)VdN!hnwy*!>Gh2#>Z;Zs_w!Tt zh3D^@bJr1WdbV;)yvbm=|IS_NKW?q8;?l21-!>_0;;styQ}xO24b435z>hyQo4Nen z!%LelJXF)Vv1R<^p54FXqomOR3~>E8X_8`VpXs@K(DM918fn84Tbap!pV?z?tf zIGHdz2Q=FY35nHw1q)l_o2a=1Oo2nDVC5^af!qVLA}l6+xMC3&YJ~d;m%-@g>)mUu@zAwm!};92@NG-F{n*sPiN` zm_0h$Za_xxEcwZ#1$1`-u4Zm3*$b)PA)u64f80T0Cr(!WVBv53?rmGir6eQEdQSZx^#V^mvT|L}T}myBA;#gVcDvoj`i&slbSa%M?FQu1TFCpV?e`Y?g- zTYAfQ9`cXs^DUh}o)nPHia8_p*R=g)&JSKlP3GH=AaW!5{7~chdf!A7!cG(kkVD6T zpdi#jQecJzNcbT02q`f6rQ4Cuw-})2EH%gv>-FD37D_Oylg)+CrC4oNj@%Du#f*y0W-YQAO-Lrl ze!IzUnPabW0R|&iTsA914({zhe5<+MU%Y{J9Rwt>ninJmVyHr@KM08&*yyb3JOYKNXXY^}5tgev_^9Pnn@nV})-FR!Kh#Ent`#aVz*I zkt-DB9$ZnuHd+i8gsbGG7#K3k+VZ7{L}wah2ZInA$>87<;1&)wb|FQDIK`;3YqRuQ zwQmAH{*n6dE3L$@by8Q~gS~sD&yM!JM(YS1vj9egjq=3|)TD}tVF;yV4lBhKB=ev_ z^fYPCEPI^~j{H@W^gid!~}ZDXf=lM#h;vxF3lkWk!0E(i8l zv&B}$#$f93a)ly`Q4-7q5?B=@LNjX!NehvIJWXy30TjRNmtakVkuC*g`sqP3JMckP zTsddNfB0FD^fWVZzSx%*X5>gMBGv}Z2=|!LWN{;<=a3zW!{9bLj1i_7vvV<9?Do15 z>?NB~k>bgp@sMWz7!OrHet}DB$;+KMCSCh#n3B``nTY+0yl$;F_5pA9?|d~(e&_3a z^6|^DiZ(-|I-yg&J}2|Xn*HfDv2{ZY(Jp&*f~GMkRje(P+yV2}p9UlgNBR)!!#P6N zm6X5YU(CHPXU3w&=DE9aW-V%z{wHf#{G{}%U+g~j>af7kTd#H1-@2RcKfMdTd(?*0 z-S>#jW>vjs(fwmKuS1rw<+^_Ocfbi?&z=r})1 z^@r53y4dU(9vdx&B}F@iMa$V*6oom-3DQ$NSoOKeO%x4e1VQXbBkG7Zr(?ggeDL}J zW#i)#e5oVvE#0^8r5pGVdzBmd$$Guw^_Gs~lWx7o`_dx*;LW@s9PsuL;BW~vk7JMc z%E`1?V25N_B3Z`fh!8AcTZk=!M~34#j>m>6AtAOR1A;pthx^T8{*XCVS$4)DZ>U(1 zvyHYQTyci7kmzV<2)D%tIighwK>}Ud5o4%m7<9XJ#`LqNU-M~Kz$Pl8CJQ);;1Ac` z*nZYY>h$>|*PUCDxvKfh`tw*52jBh8yJ|-LM^C)A=^p8o&=vooHt==(m-TH|F8%0< z=RTL__g($LuGU6q$!M&N_26JSYJx=}HYwEVOh`;HnI)senV6VRWU(eB$~=5S*yd13Ry=S8@o$ha{Z zDSYx%5_tj-=4}&@&8Nr}g-k?q48)Sxr_VXD_{pCw+p_M7htyN*uNuzPW-L3``s7cm zw$}CR;WN0U>>1_IJ7dNk-aM^pNP6D)w){!`b5_=cDHBh2l~-qYi}tMhm`CG9JDeSa z?k|A67@5zPAd|Zy$ayI;XoiIuW!OCfH^MbR2H_eaEHW-yhWs0@fSdeLaPt+p!>bOv z&fbOs9tH>Ct4m0{aaIQ2&@R6Ow#hfsskq!Oli6amg@oEoP>pW4OWS@xHXn|M%>f6M zGiYK|Y~3gs$=u?Pu5D5GaC(_1WPZgft|B_$&YM7|+-AA?_ z&ZjaOG_peSrkjx|Ku*DEveM6huQ%B8ld}h(PxsZWCZwle{LKcd?(H#?O}4-%4rHIT z!tj7+GeD7VQpl~rtpU#e_LEO}&+qz<^U3E_)$luMH@uW9Qdr;c-mj$EzWo9ltT=lO zkWU8WCRXn&xEVqd93{A8U>k84ej2!2L~aVLSILB&pKLUPk!Q~$jtEw@ZgNd-7Xa&&cJ!X>TP8gg@SMH^OlCIP7Z2J{b{+sAra^YzPZR~U z3>I#nL@5^CjiEOY1^VA>Bww@;%6+&v7vGyD3`xDVc=5Bo4CT_kuUn4olXnAuZh}P) z!_FTgn?`X8oIr|OjYaY%!)9p{TW%8I4V(x#WXwQm;j>gze1pP6O&jzM3i|tJPDWbR zE3M++i~C%?^m(j0&k)xAkKS&YulD*x3455~b>{lQu}tBpz`ZYG(j2TBwA0QAt!4>L zqgR>(mTf_jg8fj^rDJbWy&0U_gS`v~HOMFVJlH};%O9#tY~q_00$hfx$(a%1wvcqV zL9B0ptt&9li+c+p@P*=_`dzgu{&PO;^LRtpm;cpmkO^)!T^yBR4WW0Ud=`OVV2%+U z7F5gIq!X{borgjNR5SjQUg1A^THUSQ|1|#z82cXIp>|5xKgStU<7K8&rQH4uy94?` z%6S_%qaMq{y#?4UhsLrpqSEW~RZ(WBN6$Q;ncvB_!0D$NzCPKNTsHHhxpL;o(8`5X zKSqJ=3?Yv{-zaC{s0AE$U)u3{cdwydy@%gMKFf4ihVk-x)C{xP=e`=R2RoLOq&USM z%3@;aoAVI-SgexSri9u<-7YE2i3<+JZVxT8nOR(FXpGa$w#S&e!qVoa-jmdou`R4F z2CbQ?aj_26x{S`4G+{_IX2KWC33_i->Lu}n2iHqE4t*Ps#)SU$+;2C?eCQ{GzM=FE zrjybeS&)*OnwwUTevlpH2c?7JpnTAFFyzUogV6_L4#wJ#U<3RS>4-QYAF&+?IU0Q= z=1A-h)2(Fm;g^TP*i-dyyd?S)xGCQJVEWcz)JyvCC#6$sJBCdzUtaaV2Wh4^H}-g@ zpKX5RIV9mtU)UsRQ|G)lTauezUGT!YHYwlkid|n^;lKEN#;m?AN0!um?>lGzG|n96 zn!7MR|5SSV;oY7FqW&0AzY>z_WT|YIZIf$d_U(@5vrMx~{Hbdwy=wO68Wr^@pD=pFZoO z4a>GB#XQe*p5I(OZ^`eQ?zm%7)x1BntluiiE9brY!fy4`ruNPADt7{R&h~=}t09Al zY=ke)KHpL8X7dxPy$@ zy5w!{9pUb<2)n@*7HJ5N4>MTf!JR9JT(Jhg4}H&r7BUXvjxO_>9UCO{I**`~D54y2 zqu`=OQvRt>P;@qkiKC#$(KQtKj?WwxZChdt$cHFk@)Wdy8h7J4V{rx<1)x7G@UQVhj z@r(%DasTL1P-`YcYafHVZtOl7ZBQImMR7Q+NEq7TGuiFdBE`XNrtJpa#dd@mc3MJ1 z!fY0++o3th$kQ-;7_%ZsK1j#Gl=|G%TENiBUJd+;dvJ6wfmpX|KF!2z#WW&fndeBQA88yz(UJ3w1i`mFw}m zP&PZ_TL_;>m=z`4o{eN4{B*^hotPkb;_(|3D@8+#+q1K9k}-6c7?Mf-isI~^_)Iek zpC1v;x;)WcE;IDC$F(bKXHJ$OEZTEFb(SH z0V&mw2EKK#{{}rm8=>GcknSkdc3c$RB(IT$`4TJLnmxR*wRYcoZIZh{{rmrvADEe1 z{Ak&Ohf|}9PBia(wru*0pS9FIoD|!$ySlRa(-mvCsz1EGwyRkE>tEwypUuoZ_(JFW zg&*|n;O-Tz8*1i0ME123yq*qT$FTc-<$*BANL7JAm=mfv?15Enci6F(MT85NoRA26 zQHYCn%~`s_w>fr%@=%AJML9!|HC9{>o*0F^N^C&ak{D>dPtI8QK197BnZBWFK^-h(# z`KtKd=6Js9arM`{yC#8->&=K~XM-knnt@U9}YU_Lq-IsekSJl6PKG-#J?KvLUQ@FMn38?wcx2 z-Kvf!zp)T9alw!XZMWE$qd#PTe+aHjX#_` z(p5Zt|K_{m%Cg0O--p=dZ=mZw=(b_(qOVSSHbO~=Qo zOKMmWOSD8}l8(cchO5~S6iTcBJrWsh5#t+3jvf2kFUDTY)6Mi?77Z|GkYMSndFDx5 zC4BEp&G*j41Hl2`yWfyux%b<-n~w91S}*BJ`o`Jwmb=0?AKmD3XXnqX9JcZ3Mz=F( z_>4JO8;^c?)ScPlo4H6_om{+X(a3vN_N|q+Eb5FJKWfV-eVe5%HLD}X6|Mb4-)4E~ z(y`-b2K66k`_J_s1Rr`S#U&z)}!c$$Wr z^xsE4o^Mxw^3tRI+OHGdN;Pn$y~fDV8^}ktZ40kUFk9`y8kL|qCuG$$UB;8JRi3ul zIq{?kmGlGNt?olfJ%>MPZN=x-v+tD8DE;-G7vCzMS^A0iL_MZ{xn&EV$4y(d?0^5K z-%I1XJ@j+@lf~GRUGdHst3h{~ zwe_j3PWUDN4sqamqel!616A5@IM2c`?#cSYJ>}D9UbwTiD>=4Dz0@Pm)gqhv^6%s! zvVl+h?u)y4QtO)A=FaW@#}~@>Dm|`QIDhV+TG!u2mf=Hau-AaAldP_h_S~YviWDyL zGI+X6*sVCwcHtHo;CwKr@P}?Q?=(U`8Dyu?>@-ajUBfKMGT?Rc1zfani;fV`N3{Q-R zjZ9}Amd-sqCp;&jfEDm*Y#Lt^X(t02Oz1}jGWxpT8OZ3T2U7a9Q9&+9p7!YM?GJry zH%{;DP(Qso=cGS%$$wOAJ$lwL09AqN`M44l9mSOB=qPel;9S`h3Jqln7K_3ZYq;3X zBKc11_K?VknCPhRFnR=#GI*SYN=|2t16G$Z>zcK_HWtsk3|``a#T`(lO%NVdkB(9 zkq#T`yo!_C!$NstWK1CZCF~$OTG(`x!5D;IP>Yc+!{tB`AsGB3CEXwPj_lt0e3#L* zc<$zt-u2J_qQ_hObmLtQoB1(vms2N4mCk+s`_j6v4<21svu9KKVp_A$f@7zFr&cw< zQ`6W4>eVXHcsGJX+d{mI87Q;6lgcwt+A^cmp1wYj+UwtbI*@w~W^$9CeR?1N;*Gw2 zSK;_h7B78$5c6SIkdln~Z0xW9qGsTwtTKS1ngQUTnt^vv&0we11g|DoG_V>OY6dz; zV<9J?lLl76mAs(@J{ZcU@6&1q^&u8i4Md`xXc=mmVd;{ncF=9PU!nTJ5$T7PA6lFM z#3Eb6OkvicBE?!HMp&nzb}$*WgKBdnRSr-$@LSi3+Z3uA+=Z&a9o9$0L&_f0QSpT7 zsO6y5t5pwBItW$|7M-+n+o9on#mj2UlVjBnj(|vOrHOr~#rCfcN-ceqgTDR(xP!1k zuO7%=Y_)*J@FIS((rUAK%@)+CEMBVx^fG%vEyatx2=?a6*iV415;B)f;G9J34_Rbx z!luwc)q~4O9@q{ zJp|sjxy!iAW#1X5KNoCaMzh--<~G3*584L3)&|osQ1rdIK%^~~P|7)An<=I2v_Pk@ z5W6lBJh*OI{@sy94=#NmzG+V9*kK<&cbxy`9p13=8THS_vu5mDyt+~@={+Qt&>Err zFQg01tk4$+HDfZG2%RDdAjS4z)j=yd=u-G?ng3wTVZ6xp_WnicjPHHXD;#}?;kxyH zwCAWurI~uvr{#wcTa92Ref5xivq8zq&JwbOJt5iIS=yu0N`ym6^dy3qA)$)du3*1% zk*6R%OX22>M7u+zM;Nj*c*Lft-5HzGcXK5C3o?cjjL7yRMn^?PIP5kID&Zlxlq}Tg z;|fU2Qg9Q{wAk|9+l$afiv=j4*ADvEc|Zq!;|EmMGdn0|(w0!JHq<$WbFS%z)LcaI5mf|v_F~=bDc{L^R(_ehTXw2f0W!dUm;>YdYl#mxaePqse zwxU>4y0`b>?r_)gnbE$qYu^0m@uTlswLWoj>J?$m%bGiLPxIbu>$}sFsDdTA)OhK% zAs)2?db;%fK~Ia~!YG|SZixR96)sw9f5W5T7c|;G<*WPuK>MtM438tioMBH) zk5CNRA_FAfoxUk!H(0P7bmuzZ-2uuw!Hx8xL*f{bK06Rsk~$4iUduLs@Gy4ZLQuhe zgW~-Wr=UlwXotD}2ybw&Ing=52)*7+oY2{VwGbK?pnK~Kjqb|aWwT>uymW}j&MnJY zLH7GLdvaok?02hA-=~p1%w0b#YC_t7C*?=^Mt3)@_h@7vo;7ak8Si#1u}SZH{hqxURuz1TbUB0W+?81iuPQPb1XbziPP3w|Oa zBB?4NubbIjTD>~LI(vD3>CWPk`zs1+XV}6!7Ej$SY$wJP=38WM)R^%n#*U0gR4j$# zu3y*ocF!`FU>`;b_=<`h7c8H5GNJGKHm-s;4aJiI5BTQTuni?PE;dw&i%q~MUWto~ z^(b~c8esQ^C|=fjy$yE_(2cV(8!g_I;Fh$VJqd8PK&*w*ieCIMR0J4LtZX5@kved@7q( zl)hP9>|Ze6H-Elw{DL3TuJLpE`3KtD9xt1^Pv1Ols2;yy{)F*WRadczd};E^DQ%BG z-Zp2m=c~QicJk}jS-aY)?X^xvHd~_)-pGVv3|h4P!^V}M+z`D5g}9}>6Eyt_8t?<- z60{5tv?zEg6)pOXFpb)IfffOumRhtu7h21x{+2?mg=%gqP{T{dTkYtdk?ll@jv&yg zaW}L~`ll@)+|c3}G}^8~E!Bp?K`lQY)G}U!EeOFc117TZIa6=109UN^}pat1WxmcU$eY!%_x&9k%9zCx~bPKjj`ll@) z47A7&1I-h>XIG$wa>Da8>dXnu^K<$IK9oVI*C4@*J zp3A1)8H;?m*dmQBznBaeP3#KRiv1?J%ObHkh6ikBiw#k$_KcK4m`q``Gx@R}pg>b= z`4oCeG^nrp-6^f=p}(j^t9VFGZUG&J;PsocOLB4)+Uf9x7R@T&9QcC|zF}7ZP6VJ{*jEqqV-sq8^ zU{VrgM86AU^L*0+rOPIFMaM>Mv)k%IQWF#K))qu+wAX@%FnbhBO0v3A0heaWG)s2& zavsHNfdXYf%NyxUC9qQD7$9CJ&4veoM$!(bhzRc19ut?xdxo!{er&>ynckV(#~0QY zKKJ&aom0O%Z&ZEZ*o|u3(I-FalnaihWg2?-DOp2~CwgV1))T`1_Sy@4^3vfW4LlJK z*Cq816HD#tbHBP16xDagzoYG}+~S*RqJ%28Y~V2;xG6Tp8Sb#=GZG#|(Gc>2YoC`SF4HO?zY;njgthDEga)AYi=7 zNz!ecRsf@N0iFOV%rA6lVfZ_#BiD`Ju`g{HZ;MlRR!dQy-hA($tKW!uGbf)LE|0xa zdA4U**0FORcB?sfmit2YRW4tP2lr~P7vkMgzk}B}5l=HsNl8tdICe}yn$6%!&9urq zt}6DS#D}Bsz~e*m!+AAPlTuO(tTvaN6h1aJEmO{!I3@`h4ZATlCn+_2RH{8^d}_ud z@DrvCOuY)Wk~atkQGYKDgzs$dF>fHIxhuH=#KOa1wRGEzT( zVcH(`Y-QETJ!R$d=5A6>98MduYP-0;+ijT?R-eYN2S$JcLo>IbAhHbQ@NLVtv?<-S~tSwi{($^+F9 zJX;_*HoX>^@YLoUgA{7C8n9E|gl+2Db;UphCU^_*zCm4WiQt!Ln|JN){*0HtJDql@ z;{#$tf@qr~{6{WtMm(>e95C6y8yjr>Rk9tGmKYk@j7!Aw)Aw5(Vd=UbQ=mr5<-E;2z7*Xi6P;EH%nO# zyyQo{M7gnG+}WSX>wiy8AX5h62>7qMcxXa3sC0^IVLBW}DzWsZZIRXu8~T^?Cr_Kr zC(dPz&2OKh_WjqiZ4(m4Y@K%3LnG&os~&a!X(1XGt=kpz(Tnoxi|-zM&^t9HylZLN zxXkpqTjxLbL3Gq%k9T9!i1P6{lNXJ@>r9G0-d?((Yx~!G$Uk5k@lLA}M6_{OYqPL> zzZm;Qg~OIjMVV}Rh{a|xM3^lR2kl`8nbUG$!lN1Nv4Tf4_Q&s=9T{e~(JN2PF(TZN z<%-F&h|Fn2l3f{Nh9nQo$@#7N8B&Mzv}GOy0VYM$q)_wNJMiZ`$JO`YLDJuVZjl4! z)8K=6k$9aC)C;|lD>6A;-?%G+76L*^YcWVMmw@IhaSX=zf`p8KlG+(l_^ z-7ANW%PPF{_x1JFGiFTQ{EO=9MGF@${Kck?zrfF;>gr!?TJg-xnX_llob^oOif3lc znmKFc%xC0T%j%{r4pkSrL9ZXju6xI^s&=@4URiWdkIwpzeJvI7xI|0k3{ zF+`I&qSIi?iKRs?MV(#u-Z^S{-iWqwr{4Y9kH)o~{T5oR{1%$YIZbh~58iS2uIQMC z$cUdDf9kD>$G?pT%fF3W(DY2~k?WyvjCkcIo@=l}?m{7UPNdo$c)LZBGt?}&-DSi6 zzJnGMn-h+z77VpBWVqEi+|6>O;c~7ar&qml2}IGt6THU_UJKr?)}J=hw2cgnLmzr5 zhKFk}c`NW@^D<;hBny1=XAiXkc)V?Y;gQvN$AKEhFE6I& zL`31^<*PDzlXwHqa}sUX)A#FXEc!Rw^=O~%j*ryN{j^_?yrWafR5=UYEIqT|?1Rs6 z1UpT!!&rjgX;CSn;w@ANMu~h6z`51a(tj~jo98kn! zO$J-2rO9P*n8I9eAWX=DZOy>gx^f9lwHl8{Q_1SIk^u zcy$EZ?kf|tMO~tu?MB6lhcK|=I7GH1TD6BdWy-e6lxTAICjq({m$=++wp&8 zrJP&9;nB%qci;}?!v{rK3tBBXIs;^P`Csy=^gPS?mK{8G!Id|Z-Zynod!Cwb$J-Skj(U*=Na^;2QbvO{XV5B>M%478u0*A0M=u;VZDHlq ziH+w+Ey7X7QO!){=f?Ta!Ww;G$|;~@%b!s8$zCfROd zA)ywBwzdgkcotW%&T*Jqh_y5L1!da%A*9;=x0K;=&^_vN$JA4N)-hDvB>bNWn7mdV zkNSt@|Frkz@ljQ0|L5Fg_I)ywOp?iDCd&XJJ4wh!CSeO9Km-M3-=c_wsDOY05fK6+ zqJTotDk6;(DWalMYN-l}iU=tpq9WS5)c&X|@={H1e&2KMog`3g-}n9ee*ZCW=1%T< zw);HKd6w@(dPKa;#sS~!-O}&$vkf}EM7)5#F!R32V-gJJK13G|J>ikLZ}I{LV$pV1 z1ds)N{&`xvgAU#Ig<{$XRH$f6I`6I`Z0L52xH}@qC9hr}{O)K(*WKM|X$;)LgQkoX zQ`*i%aWd%hfB#~i^4tz(?`RfZosF7b#2X(+wnZj7WT)3@hndRDHV#0y8EgoyG6(<_ z0%bIau_$oU^coCe2^{<+vL{yOGVh5oI;>X-aj~#z*+E~yNpw~a4B2O60ClqH#Q8q% z|H57dChK#Z)~DbYjB8-FL?sevwYq2kCjeb`1SYm($p?B?6vmo|Yv7q9JRAWfi?U$a z;c3cTSORrL$`S8{qsPwDBPW#EZC>T|IVQSVu(Y2SER89f8im~UnZoAwV~v|&!{zpc zW@zQp$rF(Y+(M^1X@jt(!@XS#^#*BYF+DPZjH4kvadr>&1rpPYqQwI%oo9L|ks0d9 zy--2=;#{D9u+g~a$`*(<)syonDqyktDfN<6y;p>%+Iu4&FHYbiD0&8{^7`R$Zfk3gCt3 zuR7QR;lEuVaC)Y#WL}N%9}#Qp_94|p_ob%h+*iN%UFGb_%}35`tH0AcW<49QaFWWxPgHP>O?Hk%6O2FO0iK>R2A<_0R=J}C;+V$zHJ*Rq_uw_ZfQ>u zOv=gC6U0qo-Q;`P&ah`}#xsiX3_VGVSmk%2AvQ?0g07Z9)qo^okbyX>;`IXP(79QB z?4kAtlv@3^i<9(87yp7g)ODPe9s!$&Z7&=ACnhj%M>G8*UAGV4&bT8rz3_b%|VxCqm+?lXBPQ7TJ62Q)<#~o}gU4 zcb!zbu{}~`h*XP5FIjUqJUl@BNlo=ktLV(x>KFvNFw5 z&&2HBIWchv?HbqPf#fXW8J;lNpjcxH4l2IhqjoM=A{GmhV&N<)~kAFD8{^fKc zVDSitPNtRLr_<$B<<{s5W}_2MZ(K8^tZ`FJTx1WfF*uVV9n$C6)=&w*F-^N17fWRPeJ7#Jkx z7D$CF)>HFC(;S-o&381|*mP0Jg`4`8Ezho8xN9X%evuZ@MrFP7`isih6}xuT(jgyx zPL0Zceg2X1LhUZhrH)qUG7dmLZ-r;Z2wE3e!O^2-k3Aee!WJG8KLU~!4a2Bou_BBv z41-Q-NpasIxvVe@ZrVvoLZcgSCJPPk}@Q9NZOF}S@|Xw5mdw^zG$QY?TiAlQ@JbtKt=luYat4S zrCq0K!9uZ}zMk|8d+w4OQj$`JmyW9!${jj+K$c7n`V0%d&d) zae8xNmf4!eUr=@Vzy^>FB^&eT^1*@igQmbyUt)y6F>#uCSYqYS8JvRE0XLO*tsVHf zg1KYHitF0{o;1AA;~z@xiT=d8p;w*VFnnRwO%t1v1KbU>rYV2H1Tifzq|f#bL{Thm zUzX&jW2inpt9?q&9d-9o+nfdSQ&U$DTc3Bw)v9x5TH4xL@j#+a*`b_|3A>ndx~}6h zaVI25MwOODYIw}yf5b@}mFyT}zZOtw^~qO-E`>@nGMF@@&&x@e7T&`Nvl`>3{0F48 ze2_HeHlQhKG@%FzKG0`|oRcrC`;*^Q*Es8%!HqLU9GaCj`$+xfSEk)L^XhVjly*cK zuw~-%iP!!NQW_vRnD$@=Cc<2_SHvus6ah9d^QK|Z06g|wZxD1w9)GSUqY!jy0C=cg z(t(`d4EVQ03I^_w}lz4QGHdO_E2oeYr1sGJ`j<#lTlH#EixULkk z$5!1|@YC!_JhTmn<%VI(z=3m^n-4>M0=@?-jCrW48V+#}j~sV64bCqf=#Rx2J!#4Z z^u)$&MYr^VaAwK0_B8oV%m4YJSd1qS`0nh1FGLDi6&Y@*^e6c_SdL8fl}Snds4se@ zFWzUajF0z~_$+RdK8ePgRvX-7T?f6Z?XWf+lvW4V*b@z@Nq(4&IJ&=yxU#v64CJdr zEI?Mpie)yFe@_dU7D`=pi;(Z&nFc{6T%fMX-O!Y{Ia`$Wq>k);-CS2DAe;Bi$T+;e z_`0mz897rH#m{e}?%ep-Hs(&3zuBJX2O!5A>)KZ+7e4oRw+Dg`ZW5kaM{Ayb!^PHY zG#8_C5dI5AWN0MaA5PBA$q)+?nJa_OJljQlvu#qZ({qQftr@X? z#tJ>tCUV2$oau1JpwY*Qpiy6j}t8k!j8i z{6%064e+!!3PGffXcY|Y>y-P1Pvmt!-Ygyb39%#sWRA7cNGS!+wKCKb7*M2F^<+Ma zZV@dk!-uFR{bhZB2FQz-0+Tr^>ai6wWIH`|>uC`R+ejlblx;tzC`%ljKctis%0=ae zJ#^bhx~=mko;(sy9@qWJdh)7S>i%S6>93dj6ZOfQU#mi<`sAV_Di$I5MBR+cpp$+~ zq04PoM}Mq6L7}VIqf8p9OzQjz`Q-qlte%wNk?XO-Sr92RIRJoQbQlcgF5J;BEYcE$ z($6s=#9UBqkm!4cSq>Od!HiW95Gk=Z{T%q^-RM#ojFA6oht^1wwi0Eqpjy!Z;#_P5 zMyc``z8Khfw7}l3`OGk%kW}d9VH^k261-`&BP+O1Nc4!T9?^V4n72rtc8$z@LeT3e z&{9@|0=tprb6TXxEeAtEmmCV(QEYN36fAL0x5rqgo3BbH)9o|_z+){r2nA}eV7B=E zE;$7ZxYO304Yy#fkL;AAI<*jRe%Awinls$ge8|UK6)AFkzs6?r-BMk!ef#_GRuzn< zo^OSbL1oJrS{+n=e`E00mTX_H&*NRv)bEp>JCC-mr?c06aZts#la|eHDB64btd{bH zw@J>>2yA(u*a7Cn|q;Ga6DG(Dp z#W7A}rfFb-n7P{I856V0*&JuOr=Yo)xH2iO{;I0J+3@)@>xTmihu9Lt;W2q(-SBYm zDlUO=bqwgH%3+yGLW?rRR8aq`+ioIeC!=EgipNzoW-)(sccTHJsHR5qEcdLK#>^YC z8~YkrFsiyhw9{V{{U9IWKTd;gr!%I9p}+I}T120Xssg2Owxqf4wtJlphhlO$ne11X zQhL|m$*V#o>#n-*S9XWDG~9RZ{JO<`=n%V3S5-dhMxRntHpTDi;c>gF`&Uj*^!9K$ zV`{{XnYWsyncoTtEE3783NnrS@aRNaHT%NsWtJZ zY+=#bORkEKm~qv=UIe|tr59n|Ul0#V_k*8;F_Zd8J_uVkq+f0~c9?Z$h5`(fM$%{$ zueVS*^;%#^2I#L@U{1TAVu67OKQ^|SwzhN1Un+rMaKSE9kh4PsCM&+-dYw+4zuKi( z+rrebWw&_v7`WEr7vj7M|7+#`PW1>;_ zim9Ryn`s*9QR~HFiD5{AbVQ#4F!6U=cG2_dRu}U&%kuCx|Auw`n0Q!ZI2JO{J`%du z1L(*|hIc)nxLN<`An1G=9j{J*bUxRk{U97^>q%`}c4;lY@*s5AjT(IqN8G|;A|2KlW)om7%5(teIagl6@PqrpUJhCY z^CV<4CyLCJS6}^rk1~s?ed(GX#M2kHab5C!B}JN`gC8R}M=0Wib3RJ~rDD*+=>VE5 zRkDJmhN(S_dSRxrlrE#o@O@sfC{}q{+p)I8VzHF=(+5ADkTOBTxsNvY4#OgeQFjvc z%{s`?U$}={nMT7!#Hh@NH1NOAgCQUjyc@VOG+^IvSfyX z9=jwOUk}74ydl2c)0&wR=$V>qjdj_A;Z&X7SIK-P!HZ1l0hL!Jj&q%Yj@Xc) zJa#dtG&#EoHn>YU?lQOYF6327y$i&bOYV}UN-MNHgHC4RinB{fVba(%$R=OleG{Qu zc{(x$wgYBW1$VP`Mo^n%j}u@wqHJVdQ?NR~9g6!;8NGtbw%Q~&3-?K6O^j)+!{Uy2 zIbuYo&uf>V#nTx)HnfZ)p^il|dz>QTdzj87&+(cnzF-9TQkp4}KF?FizGAKr7_RPA zj*${ZQPdYPN?25xh8bvq$pQ8bPS24@xo;IlPs&Cdb4}87lP4p*@qrJ3Fpzd&-+?#$ zhgFb)FTZ3k13zsQTRV{kXlGw|U`-tg_#ADeXq4SHS*I5P(CBvCV0CcWEQsB+l^EQT z-Mrc;0W863Tx%5^UaQkC+T2`hlZj|_L1=c_yqK^b!ra@ft-p+zaA`|Hb2!8qZy;|X za~&%z6fV-Q0c$~#*@!ie_Vg>KJDaDA`R6&g=@JwLwtiH-9+{=M)+Sp-7920SWD#I{ z?3aLDh|aW#B@RQg$)#&1HWOS|gpHP~xH!ff;s`a_4JNFYr5GeK5=A=BzX$B%@B*LnhOKajA%KamE*D3c0XyYvID>+j0ot#PM zoK+^!?OTMvujqF8Pqu%8x8SglEhyp?%-?RgenbZ1&yelA=la2`#Vey$gi&)bMIcIP zn>a-|1{(MOCwr05@eSM);jP8xfd3Asox{a|{~f1AL?n2u%4uJ13oBnEjnenneglT9 zrc*kmCRGB}#|NHGo6&Q2tb4=2&#XY+_l8KBD5M2wE-AOZ=?=V^dnE16j0yeSM~d`s z4)KYDgpxkA2T634ga!@n6N;EZ-oaAH5ej7ub|i)(Js_IHQBYms^VD{lJjyl2d0#QKDqZsc|AuF+Q0zNrQZz{hmiqr1E1{lfn0G$|(BRy}#(fN9hF51hQ{HwzcG zJh5QW_S&ff2TsMFsf$_`Eo^C7xTr<6OdU9A%CrIMt|y+rE};nd0H?Iq44yiDVE^e; z2QK;zPTbKVo)|cFD&Mh?ownnN_R!#|QwOs%_^oz45nV6kBgUX>y`3jERi31I{;NmWbD~G|mmFbtiyqNwN7QHmcBF4- zt<`7&^$5FL^oSndmR%7B-LKKHBY1zI))3F}h^_vSP&d>M4e~?cL7M=IWAZ-IK{3Zg zhI+u*EziExNvXhZ7~N&`h(mi^2I~<;^kAHPE&QA$_&Mpw$cPPsFuUT?!@JSmy=0uO(1_xiA*8s<5O-6)zirJXD>=3M4767LiIdEDc zuNGpIv}#4ljl^UEc%j8)wY%*xc8}d_kBuksG+u}o3J|RRpdlnU6I=;y ze~jPb_xfXf2}y`XR$fL$caCfb75tvF%0_)pYKms&i z2p9uSSX?x3Gn|L<#`&G&t!cs4*245o-&;85nz~v31jKe$@z|>DJV(akj%@(L!=nI-7wvsxM2LvYF-`)i3g+0> zqdkx69B+YP(u-)nAFBZ7O*Av&K>X9&#tqEn-!cRNPsnnh+LhTRhdb10jkRNnIoTO5_T~QB)4C;pDlFpO*Q%3|xNU5NMLtEwHf^0d_t8h^&fTgj zjf@>r85uLSg8e=3(MQp;=K(4RHzMem(j!iz&Sc%7Bg7$^00Au;A)+9&7kk&)tB$0R zSSbbn#Zx^!EM%mmtXHYFZ9?g^Tpm?pK zRZzu_CZmvl_Zm5dVct+^?P!Xy=a0&tn}ym}l^2^;BtzyMNy!&z`B>iaP{eMwne-a~ zUuY(Ht(;6W!@7`ZsH3gU|5r;3UAmw=lARf>O7?{Yho;URT2h~$mTtGNFq!HG7cImy z=qa>%IHz(YpmO9+Sx~7QvWZ5C3tIi3s2uPrfkYwNHf&$M;FE`?ujs<>zsKEKWRhf) zPe2=7AL)zrhhQaEwgRyNLjuAk{CK#NHPB^2R&{W!pKd@qbw=i1iSsOas4(*5tMsH$PYd%g~ATJ*_j8 zFWZmp5b|fv*vtAEeJqUwmQVt@BQg{kSv;Fz2>}R3j!yt_jFWwFG4@zFCdOU@U<2kd zqqpl~R(lz|5Q1(g)LNs?hVk z_EV>)DIc&%D~@N)C7D8vBO5f%&(Jg290)V-IehfwW46)a1b^h$fCJ;B2g;l(dkjaP zHSlXDsz=moh=3^FZO8%3WKY!_=a@u}!8eZRfFsLY{MbSsE)hIp*9~(RqIP%fk~g=T zgbQtieS=bU=4r9Rf8oYRsaXd0wn+x=wjE;bp^SJ{wJ{i-8k#Y=zDi1)pz@*r&)r+RiQdgZ_822fB(L%e@xUl7?yDOE; zcxv`57jC>Pq08!}{$)*_IbD>D2iiaBO6wxL`hb80mnstDEUe6fBnMFkwLUrCM+st) zys>f|199`S<|ZPaJp&pChAA>@>-^p{AMvL(yE2-M^)COKTwj2pO6htei(Zn|Bba3t zdzdXqE{wia&6=7nS(V!H_P~86I`O(*9IU>1penN8c3}mv0D}BH#Qq@03#n+s`LURP z%wDHChr#qMUe|Q<&_Togy7uL_Y6sVTvC^62vA7F*DyNdDYwgLIG?3Uq(&~CYduHy; zC*E<%*-t9(Zd#*s%$&FI)REiI-_Y2Ep!M|8C6gwMe*ONj6BLWvrM%w0@Ge?OX{4Ub zS5;%hq`|1hN|SpvEf<@wQ7spbXGFiUJORzHM_7o5tU)vfb=Vjfk%z`uqYy<{fpLH$ z9f0FNkW_dg&& z;rTEOrgSK8I0O^dyPo@xKtz`}kV7yMBw0YecNRRbJ@ zr!nfd*1Ie!OTU$e*TfBsIf@l5Op^3LI!W0!k4~bK=PBFhgn7#2%66JYC(udr@i+TY zwl84kFpfGwcv##bpM^DlY$S_iutlC~s;hz1L5ZFmH;Tt4W26H=pZThHYFprr#nj1{kSdnN7OMw+5%ar+czg5P^S|(ZwR-JQPx~nmId^)_3%6&? zK|S(OkF)Snivu2L0sf9Vu9Jy3_Bf*1faZz}wsEqJ92acI?dIb`t81z+HjbyUB_jN& z3`0H4Pgo4Z_Z-tPmS&BFn!JLN>b&jryZ9n1J ziBvu{75TS~io1GA!L6&5BQc`wmO1w%wBL|lp4M}zKcR8bn(ytXZ9rHnoO zAnDPRclu~;b)r-~{PSWY7sEMp@8?BwO z=;zKL-;ynzXEf;U!9Bj~@c-;Rct$MFpL=O{H*5TvBdcPi6J~yZ_~^;|Y=h?(gGO%F z*WpN117Ojv@gY`T&3K_n2tX20uVEMi3}35DLg+jK+2JLwHPFxp;PktjujUyF@=IJo zh(_M8WmuD_0h2fW%4;3H#?bAW9hY45F}p_Pm@-g7v2x2KCnAeAY(IFUIyi{2KM}TN zF(n}T6Ek{ex;QK486y4mB-!szbgKu%UM?99Sm3h0I4?u8DhUAB*yq`k;66c`GmOol z`izyaYy93sw=Y(Pn@e1hC&mtL5Et<4;{7yEXHLsv9F{u{VcEf6RgER6c+~9-Uh&^* zxw*Q#^OcEu1O6NUGV`y`*FzTULWI&HQ7#8U?x*ba(IJ6-NiTU{{_#H`BGZCJ4?M8w z#~&|6MgE^>V*h`po$a`Q`LF};dL~&M=^vZwPxI_?`xhrQ#ZM3F7wei#(?u)U6Lx3V z#i_yitZ-Il?~ER)9xVU7fZrmiR&R{npCsyRFUlW`KpcrspODXzlBCY*f&8F(` zpyh+_K0BD6&QtmVWt2XYt*pAgx%SCx!gX6mpZRQ8?h1p`^hmC_mnP645)xLHop^P2 z#)Lj|3ZHx-Qhuyg4{D`C=A6=N!?Q8Z=~me$`Q+1FdcG&(lt>H2W;G%XzHQ7ZhZ0UCez8%WZA&<5Nwf(rTNc<#QjpJ9QHGnk#^B#D_f>YVDWO| zaD>V!Ti@#WrhNLykt5)EJR;D=^)Ta~BT9~8M#^7e-F6%}>o%7etXT;6~x6EQx}EfD!4G^i6Jh)|N@e#w=m>Vpv_nG->3Y^c#B-d_@% z8QGGtb7owwOpVTrUs9&7J^9FrHLaWFi^_#(p273?r`P1=yxHiE3lc_bdhC_E7 z@!8o3%646VjTXi#TgVo(l0YxcrowE{ffz_{JGm5TCG#TvEXe$1wwehs8EP0LK@Frh za}7&+NUdD7G!u((91aAnWC~jXLnUEkUVl2|H)k4@4-aW}JPi5y^Negn9sHQdtZOxh z-_a;xCSIoKk>CY=9=yddV(6F~6BY%3 zf5*bL^2PGPzNI%WW6u#9WScle{s8@15;2k%)}7rHqtGivjEo*KS}3V>@Mk75SByUR zX80}ngQHx&fISf(W-G@p8jk`kqq-AYk)Oj)>HNY$mT*!Z%{=7*_$^z(t6~S1WWi8M zYFc`@2hi$!XJ%#RPm z`>8!oKlAL~=bnFI-|zST;l)25_|r=-zjE-LW5-*`pHIAV^4(MK zoqqp=56^sb_G4(&`=PxhBpFm7p4?74uo`kA1A8v5qNC_kx{%&Z*9(V*GvaT>my*+y zbCOGvcLhTsT_`D(5vmT=r@i@;0Ev&_4qK^?TA=gK!4iKY)=~@U5?uS5@E*U`jcbef zwL-|wubqNxDRfZKA$I(L@*c|8j!F3L-!ZczhK)npg|-g}`S`()SA0DB>@2qDqnkgP zOvw9R%YWj7*B86avlH1d@+1FdTmCnaqH7jv`X8ti#$&5A}h!rv3~r5tb`ZM z8uDxMTe2O4em8J&my->U(!V2X$tJQ2nu;^z8}bO*NxsL^ejwY(@5md--?f`eBh$%! zWCl4x>dEWmO>&I91)rI>$=}Fz?dX(dmQ>&e&TesYqWAnyRT>+j?oSxsh<8_12M zfy^dz$X3!wZYDR8TgY58pUfk-0>A1@vXIG7Uc-`Wur{PZyYCV+k~RSHD6)tLy=G>pzKEJiBf^{ zwQKo3*l!d%2-o}-h20ZvS)8a zsY5x8!rHV9+k@))P$nz*@1LEmh5l6t=LiV9gUE1|%KWjH{JG%~T?ramQ zKdax*6;?;~yzYh7uX|y2X5)5wVfE@>P*<9PeHcI9@8}zfvEt{TozeNhwvZ-U>0az( z^=`!0hQh`cf0NPL7W0C)^#J}}hq4)kwS|qrS*_IIoL2nCx$GRe0$X+u*4J!Kviq~K z#d&=E*uAj7v#;2gr>N(29K{xeTtGR4dmU2?zaJYL*6(aQ*gVB~6n#utKSlcv&!lXg zU`}^@gRS-)J{A}oJ`ZsXDZZ?*Iz$U=U$o%fuur$r`%(6xoJ7B2K0(sp^MUOnn8&d0 z@OjVc>BByZKW{VUHlH8td|b!pEo(zQj&GF;K!Ila^cO84@95>Qizz5zR;MIkWy%&%Sk`@(L_ik zaJl-E0c0QsewElL`c}C^$ z1P5aLX(ed%D)5WD!JqCykKGIUdmp&TdhjPuU~sQZpxwU$)qV*2qhEtZJqmvE7&z49 zWIL#K3weU<0AJflo+P`#wRVFa?IBNdzQ8yE;|lx8@4-?2KwbnlJV5?LULr4pHyi}F zc$K^cF84Zk-J9TWDrY;!xfYsS$!D8x)iypWzLqQ)VM7^sn&s2OsFmD-GR zubVe>(M>b!=h$wlzvYI;8Pn_M%&Whpeugw~{w)N z5no+4$W6| z3A(#yoL#eI}MK;4jcO!-!o;IwwnH7?r*-^e8f_2dC<~o^;;XQzqZBN z=Gk7i2kpxpg5x2_ac7mY$z^rTa_x2f-5qidcHi#a>VD3BCgx#Jz;mPLYwtMk-q^a> z!*TI(x5l;lLcZhigW^}iWn+25dx>`?e(9g+e;}!M(%ng42T}t^0)I(fnfzMviQwqq z^x#dwCBeIcn}XYePX`YKj|ATfeir;L*b%aXe4+GEekc+e78)12J~S`1EOc+^q0o-d zbD>v4$3h>bq@_$rc{{Zt^~2P*v=M3Fr#}(y6TUaRH{8*qvd7as2ljlT=b2uXUM0Qu zXAI3~$#^g0pS>%3ugkP&PRo2Qt2KLk_KBQ?oT8kWIiKfF&V4xdbe<=#0sn5xYtGx4 zPxIf;|Dlhg&*VN&_BmZ37vvR8D7c~E)`E?N{=!J%^ujNT#uOba`dijOJ|q9R{CRE|FZdI+spo| zd{+5_^1I6KFMp)`<$gK+Ug>wN--i`LD~?rs7DS%33zrD@q^AvQwU9& z4%-+RU4P5eQB&v49o9Ifal|yxTYL&TI+Vh^zC&_y2rAD%kgzFoX9J+&$|u?b!~`z| z-IY(Y2aw+vzHV1O(H?-u%9Z|zb_TY@YJhLll~1$>i0w*$MEinmks88Cj8{I<9v}`A z6unnI(H;Qi>XrV8b_TY@Wkx2(E1zf&5cie-i1r2Bk{AnYnpZy29v~hoJdUq?qCG&o zSNbE`7i>#nZ7@Mz`9ynw#9ir+XkV}`@!8>^aOD&20TS2HD zr;|9Ze4;(T6sZC%RLlp0dzLW!mb7y`oop}rfdmX((YpVo?>I`w{#T}L?Pyf|ax;8m L*;UZpvd{ko7U7TT literal 0 HcmV?d00001 diff --git a/fonts/VeraMono.ttf b/fonts/VeraMono.ttf new file mode 100644 index 0000000000000000000000000000000000000000..139f0b4311ad2e0369a347b3be6c46e6c2b730d5 GIT binary patch literal 49224 zcmdqJdq7oH_Bg)x+2@@5e)71yxquf?c_Sig-y`84XoT{ zYwfkyK7lJhfpq z{r4HT|93*_U#lpsTJ>sT!a{(5oDi?c6=fx*?``~J1hh9p`_UC}L7&F1!F_;FhE-J6 zuhPEx02MvZiBa9)I@S>%O_S@`pz$E92_ux(K>zic zCtSyr#A$t8#~jgW>s`le$aQ|mu|RyZ_qf`KWVCj&>sUn=>ddZVH3{(B;X2llxParX zV}mtZ+cL3c#p>G1B^CAd$i>6$32||W_C>4h8I|>Q^|fUsRZ;ew>cuhk^ySO#h1jaj zURYLFR(oezY0N+y`^>W168rR$>N@+hn(CT?>v$Qj;>GB~nyQlO!m{OMC3R)?_?Y;( z|5e8Z?XUH0&<^yW^j%qJFR|CxmXwxNmDDb?*OdR90E5<`Ehww4s;sN4tf{s``--yK zG9YwGZAo=~S!tBLytb?iA6#5fQoE!q%3fb%FR5N_Ur|)@#31Q70?_T)K>uX<&}%es)5kR&}?iGIvjwN+Dq!{Y8F?PK!5hq zn#B!OW!3d1^@vY-sPNRD=&eLV%%umdcUe8ydKmK4ghRPX{k)T%xCO;MM*7S z-LSl*Rwlo+tgdni3@uS7v5C)YJ<7L~zxLbwee2bA5NHI;IA_+;6tdKfqMk`*gpkd-W24uhaZmWRxk zTNz(pQBrTOD5(SPmsJn&Uj_-?4eEHQy`j3)h4LV>vTX^K{mcI#*}9tLIJ#xgp`c3a zAiX63u+BA(;m+b^B}>ZeFlvEavch7+|GjFtMJsm&h6@aI+46FQcayX1+4*@z_UZZA zMYGZiv+Oz3?FEJTGjlStGVP)1)8RZc%04TnXmb9HB0IDwOwTKtZO_lPr{~SKPtD28 zjIw7H7ZheqpKi}DwC7AK$j!-uYdLunb7y4cB6g*S}7o+S&h3T1D)6xs4Mj?jzMU%4%?Q)YC zz!G5Cvu5JM(^n$F3Id}kk%qh&82-reP z;5~2xt^%Zq`FYc`ZkquYpq;x55Xj^#nGPTz9sW<0F_X#919A~gQGOvX#D&VNoatFn z_VmJ>=_rxx!hAp%Kv0srU$&L? zD{Ix_vK27m>fD1|F_N-DRjepDDHxfGF#xTeR1L#dxh5aN@PzRtyE?_n4cG%Yx&VtW z8(}mfU?#yUDMq;T&N8rsb!hp)YSf@nSy>5A6&akb?0?MskT;P>hQ>XMj>`uY`PV`EpYTp6>- z9e~AvDI^m~4Os#4VlAm8OCT<-Cw3A^7L(!dn*h;f97%+uMbN@dGN4U8se?}~DI+Bi zp+>>g98wMKW8f&AEQdckM5}ICb@EvmJW~eG+zH>M(DIjX>}00gq6FGc2gud%gq=(S z+^XU8%l7Wp?zZlh(a?7d;Drzh0pfD_l*ql?Nj&r%5A^(hN3nru|JO8Q+h5W#l_Q4(b?i7t_Q zs)im>G6<_&zFRiX<6?NC1gSZjjFO)B86hd4qx2pn}D81DK5U{nvo8|Dk7ED9Ijx5i08}K3gio zL)vSgeI>wC=(EEeywU)CMJR}CJ={ku5SvO_Ul5x}xQ?8%59t9l6Qxj3R>E`0L+o*o zCwOHAT(5y%8e}{bJ|Q-x09zS1mB6D0fPt{xeYk1(We*4)Ik^}xYmlKRTwMuQ@#z{F zmL2X^0!?^rC`E4ggJT?rGv-FmqA&t0O*Tk*mcks-v2c^@VdhFSiq+i z&QLmvB~V~j!a4S==&&2B|4y}AjtaJlo+%XGs&#`Dt(5su1^xWbJ-A0hIZ#*&{6*=Y zyirz4kEkg~NsUZ*oy>`)&|)#%ceio(gL;hg)_`WX^&TllO+=X}8de7x0QU$jl6ynG zErNDv7YF4qC@nW%vA|;Cb4VeMZ$(;*WITrIo5B&i zg7AM^rbsK&pvb>U{#DM=YPtFJ+Y-k%t7U6a4*e(;#r%R>|Lu9S`Dl?88W02IJ&tL& zWkdXN+~GJ?Y@LEFT3WQVZrKm&voiKj-*CJuylwy}cs58CK8sd%3GiT0%a=eqq^QDm z4WDq^QlwD91ludz{W*{D&VQ$AP~r*&gPMkv+5w;cEe5yt^K*U-QtIY^ojfK`=GX&L zFjUGo8V0R8a@#KRyc+n1_QlO-JG4@+Agzj4Dx*NL%*Yq~pcg5FBZWglIlofYvr?JE zp}*oAL*Yq9#%}JqpFq3rjv+!JE*Ls46 zJ&Z*VLwsVWKUPNSVu+VYKx?pf#n&p@HE3bo5dZ(MT0bAPgH$OoH0rV9AIopiyU8R= z=2kw*BSmmDo#X@WipVU8Fbm~-IdIJmv0WkDnF&#MCS1*gE1}Q=@8JDVd1TIl<03K{ z+Rcz*DKHA59m1XsZ4oxc>v{6oRA`?Eu+Z{lkz%=zEP#ek^PxY4Jq@nr!Y}rT?eK|- zaAgLZCan6uB@hg6o65-ij4MR{BHCromYuz@O~GIUQi<$nX$< z>_1zEnf8A;3+)At25xY0NPE5rxZMpe~4`!w9Nw;h4Swt zxQ`epl2CXx5n2^M-`HXj;8i4JfjuF0*b=cSg8S*f5qutdohn~dc!)efDI+d}P;lOa zeJgk%|7W`3p$;JZx$uX)MLtfKd&q*T)8Lu{SAl8=tdJ7KTj9nGIM0NZ$OohlVcWT)Tdr{V zxH^EMM8NL(pyKxjV;#j04UI*SBW|BL=uzCZdJ=dU#rqCzH+U5}i?bp0UxRZXZ0q*V zznnWGrAqDs+YOC`-O-2=O)7IG^p6Vu7$ITIuEc~G`zcY15^G>ouFSG=HlWN@-Ln{+ z9inf(b^cceIAR=tSSWqD{r?~=oO@v|10x6Q4LPh}gS{!-{BOSY=QBo}sp7n(7T~Ou zkLzWus^Po@ut2DIx02ii=k7U-k{>`C24(d>$-qs^|HOZc6zf2PlsQ(V%wdc#W1ugj z3^7&aYi|B394MFXVJzXs68Si&eHd$xm7g6Nmtx$65xb&ON@f7BVLwZtPt1hX12$tx zEc~sM|6(AXQ2h5`1}w%E6%x`(&dZ;6`T+cv!`f>n+03mY+`wNaISp+%xm_ncPq)&e zaJ--N!S@F8E!DDDX)+vj!L!AD2wZI@d*r8^+2^Ez9Vc&*v*ZIf`kbaPc$U6JLg+`( z&(?uHIMxMcr{Q}I>te+;m{yS|=(7NE4e6vcWE}^;Tp>VygTDw@-yoaeZzp*ID1Sr7 zYy;qbnH(Y8$Tji^_a&JF$4AK-z(*oRr61Zut^=fYZah~G?alzS-DEf2Kzc|WPpB4J zek}BGBLV6Wpnw41_6R+~BghZ=FrWf?x1S!T@mwBx3!Yy?ir74M z2m63-`T(j5w?&lB^QJq(UUZ*!br1NPFM2_<-aumZ4I}QUr5`@mjH7S`vJ~F z0JA+Z#e^K;3WYo&4`?ojYkTDHX60KnlQ-B6;QIrdL?`pvEDh*c!{?Gm$UcA@0h}SE zh9yDoHDryjUHK#J@E0v?XDz@{nHw~b8&CFd<#ZchdmXr0!!k)S^bsgrB^&7xz?-Pn zk~*P>5KrsDZ47YkJ~m|G= zv3IxYgm=BzJ8Rk7V_6TJ^o(VfB=*){wZdBx`>U2+l-OS+cHusYa3O%b>CN7d*y}Cq z{5FShUSj7Yc6Kd$O=7P~>=lWf*=-QIC3ae3rzG~W#7+Xdlb-B^o^}2Cn9wD$KOdhj z{P`IBb0dHJm_s-|pB;Dd#~kda#9nG)oz3aOixTUApN<>s1%P!#V$YYd!=>y`Ms~=` zo|D+KlCz&ZBe8=Ld)ms{CHB+-qwrJ$J78o_?zad}MzZ}D_Qxlpg+H!kPeijnNNk_P z9+z0#USFZDlUJ;OKj6di?B&z8!ha265AlLdo3Blz0=uxi8Zcb>+V@AtdrP1 zYuVZ$cDKaV7};GCTPd+SCDu@{7aB~gp_3Bl`+U8g)t}_+tgOz-*GlXTiLH=WP4#r4 zriE2kMGDo^Syd!kF0o|^Y^lU56IjI!w&WNqmspv^N+q^U5U!6C^esP#AxMrAlmEBpWNS6ku>lDH{{-CybfOk|j1e+EW-Uv81VNRGgnM zYAQ>FpG1izK*I!y#l!7*KNjc5V&N#(hs9{Tg_vV3I?6+c_GHnW9CjOJwg^!kEDF(W z;YW^e2qPsn0$Pr6u;JWTVYtL1B^DvEa1(QQX9$igHq6ArBo=Bi384}Tu}2FbYneTo z1y5x`&~uQ)0wopzybX|;KS;&jm-$J|S7JUAvjGHKHuLt17Q8c<^klXQy_v%6^Cx95Sr7ciy~NP|W)avkwUY zhnPcsh|mVH|(n z>v6C1=Y^jBJETWxS%0TQI9kZs8AMYuR)Jt>=vE$J5uOuyUJb~6h&WvXh;h^sCjYT@ z&t7~MfIwu1AE1nbD#$m4E~qdJCR3bo0X9_=BfbI+^3pVUm~<9Ha8O`?zn_oI+rw%x zn~Vm%R-;yA<0pFB&6i%cA-buTQd9d<@w+>rHvu|ii5`h8(JMs$gn5LqFprR=5cxyH zSR!|@;=9VW%4^c+MK`36D%vWqSMIHlBs#oEx=v#&sQSC2>)>=t=w7L0w{&=yw21y5 zKf7q&Zo0SsRp~HL-6g%n&w-dqgzRlBDRri(BZm>ya39{`8EdwAP{+1mJAxydgFLr+ z?4ZrYkRUTJ4pT=7L?`-t2$6Oph%?A$VyZavC0lB*Euk;9*W7pID$w&vLig3{SIt*n zxqj7RO|hg{tTyc^TvZ~J=9SEZ{dNFGY^D$p$f#l->tbROj&9!4Ax#eBt;73lmHE?_FP}DT+2+p8&W7md_@kRP zcha=HrOT#GTfQ`Z^Gk6tvGr*ikG@F#7SeqSKh3X%8_SmF!HwwXhV)G@b;3|0DK|gi z&%kVA1jO0TI~Q5ZoYiF08}vq-!JvUYHi3E|_g=Yj{p#Cq0{0YsvDi}Lz@n(k#;@UU;79mcWft(t>`+Qkp&}v@ zQCn*>3sbrl4Q6!HZoy>*Nwuo>>pO`YWy(e$_(WUQ7pWU}D zA@0>@(l=y}Tbos~V(jR7b6)c>F)bpH^jOQp4+8zbc)4 z-=vmjeQYmAIOa|pxBf!TALg~b>SHt641{uK*3Naw*2VfFC0lr~D?At#G%4M(LE*Yw zrUYu7X}k0-YY?q462Yp8d&r|kgNiV#2qnZucq*Y6_ymulRTDWcPpd5~oJ$&IO=b-n zH*DD0*80#xt)lgcH14xcrLmt~rKkV?5$)~;xbpyRgd463;i{-kO?-H(4&e6nCJe$& z^tO6=a;mV=)}&D!ohQR=1L&f)S4#cpV=1-w3;N0@SLiEPlf9pt!jA;Kv5-7xl-Zyo z5JjkfLN$9#u;?GtQe%r%t=BS*XknCb#Mi{@G`mvS=K-@~atFVf-wES7!s$sK*U&cMaTU{Zemn_K`)NfzVgQy3dR7iV7$IIE&?OjH z3wNCUS(ewI1K9TV>kcjBDUU!Km(F^P} zz20|b_hK4*L0V7Op=?X(N34q502bHMLE1Q;5>SM0>>s2FUDHxd)BioU;R$H_B@D_> zX*{$wcaVJ?bf73rtnALh=$CzcG+w#@be7-D;FD$j0(>}7Fd9U-AcoBcv@8*P#pAFBZ7Mi}k6AT=Gakua)t`msN1tgS)%R-cxjUBkSB{KXLBA8HB;2_6Qj25`(^ z%*|J>!SAK3an83PlS5;b;u1+P%8x$aC~L?m6}x z|D5og_?+rF^>do%w9n~IkQ4L-cY>YZPY5T(6RH#H6Pgp+6T0l*LdMkAU|cy)Q#J>ZQH(M z+qND5`tG}b{p;E_?rL&DLGqZqTyBr_7wN2YPWlUtqoZjujcb!uN$aJ1rB!qby@#%& zTR?Kx!SiH;B(Aou2tBgBCQ&Am>9%BE;y1VweVsT~rie}c9Fgw%%JtvJOU^rcFENL|O zF&=HMDAES**}jHj)F-JlduQX^*H$cfwd4b;n_W7lr@g)X42_v^S8M*-9T^i}k5BmW z&kIl1r+Z*5qEh#HQd{SFi+p0aB~m~ z4ffOo4+ne!;Y+<>{6RB&K{Zi1G1LIlfo_!tw~8T!%jJe84f@^zq?vl>9_gRoEqQxM z`74X|A3prZ?%mt=Jg{kYSHd=)ra5wXZWzQNuye}-@9x7T~&2!A|sF5 z?H|0b1`=-^P}o208> z^-AB^?QbN+AKKS;*x>+fxGjti83x#ese*l5wZW}s?bAFY^>*;B-Yw=`j?f?yZU|M0 z0n{Vdfrh5<3Yud@n4g;E&>)V=j+>JaM8_0nhha%V61=JG%@wh-kJ5HbJNZgnd-c0t zU%M>zeM`fr=ah$}%j+L{X#J)wTZAJ=9TCz;(&weir0@UpEd<96^Z|Mo-5%V({OA); z9R1TX&mIDfZUbqeEfqmDRHLS}~o zC!ynzZR}wGS8s9Z{v@Gi=8g5jNZ6u9Hh{G9WSbiXQT9Zq!$(hABgEFA=vFIO-H4~+ zeDuRc1bGb$GHHUm{6krgDI_=!gw`ud4I@dnsv~DoK+lITz~PQ_a4fp?e;C9+9z&u^ zu441fhc|B7`LJ|u{R7|r<>I#wtZ&&XNms5&H}_6!TzyyLx;3jCxihWz-M6c?Y3n0J zAxG97zIgHQx+5VWukAf|<&(2*XX&C<_uRAUuEzDK`|E(BY?-2AWSle9LnN)f+#nCjFLVRi<17&-zfjBbXodm&O=;_Ta5i%LDV#a`j#%E+H3!& z8tFc%M%paZ1q05CU*#h}9xCGRG;sUKL4Kbo&_JHRR1ZcZnm-UL%o)QV=#U+4UmqVK zU6fM5-2w#J{{sY^c{-dPYViLU1RT^do&-`A%ncx(fqBgaiig z-AYsdIa63Vz*uEF#40O6??RkbfrkmZz@8PKQBjUW@)4+T2`Kw(y$~2_I4_z+`PF^T zvcjJ};zJ$#dIORn(cE@sOQ^6u8pV#su0)>1j>yD54_+VTJ7F4r#%DX~BzhJYWL5 z1$i^*M-Ws~tZ`=OV8*Kw^rFMp&zJEWCpi54d@}<51dbPdO(fX7&9q(L>d_LsDMYmU zdTRtq{OlS`zYq5|Q9BC`Lw|S)gAs63%758iUA-<{yJ~&|#)o^Fz$?=P`3H<@7)}I! z=CtH#B~AsrU}_!49qbxkG-pEWhN`^7ix!-yIC^>Fg5s?3Gw09K2X-&oS~z=Las2G+ ztjyynV@^JvyJ6nUjH2fF zvi0kiEo*GL-?5?a@weW3ykOI?Ll0b+F4HO0I(m6ZT-utk(xcLRx{9V=yupR6fArDy z_dfcl^hHft=C{X>f15o%ZBG}(GcQRmN_TmBZT9t{f2B=y6Ma*<{&(Ps10;V?_KI5a zh%=oyAk+o5b_l!*KB7Yqc#VT;)$pMXEz=SQEJ`sgcuiF+Jp@iu096s?%#}un)#`vp zN_qqal-p&h<;kB4=77pH(0!x^JA7EhD4p;0(-IS`Ks6H{)^j+X>3NMxRBxhNIrV%p zpRy2&fpG{6<0^V!=JluV=-G?a{ogIWD1`O%?AaS5=|%|_#2BnB68;XLM-B5FJNh$U z(yG<8TDQNHw5|w6P6+hM5eis4iz^a=jFe*d z9N^3b%yvi!z2jepT7G}vU;lh?!}^D$DfH;4KWx~r^GWHt^rMu`o$bH8X8VI%xpHa3 zinVu??tkTlt-ts5zR-3a=K|ZnBFDps^CdA(Ki}ucVeeLEcwT?l+^T6|yZk&7^dw%4 z^F!1I9W6vnaS$82^}{t&R$|}L$$b2@eRHLcrPDNx2F~3#ZA$yhGu_>1il53!8a|x1 z&=s_r?ixP)!gwcyyl+TvN`GMqA9`Az>B|MOQ;C^vKO~XK#{)rF16El#Wa7(#8Eh(aCh`Pd}{`Vx@sP0-;2`ERt@Ram6aa7_fmDQJ-OV z_7`zG`fIrpeJe4t$!_oeM2@IoF2)xFWDObS^l(Au{{$vg20KctfK?m^n0q;#!jLNL zOIFiAk1Okc6cUc@(&YC3WWci=WK;k$3M8q{5MMvy&HP#eZjn=vzi*J9jP^(nlOSjV z>(GajL?tScE-8t${~|F$={SxT+5f_9Ct-k%Fc}Xy%f?Hu(v-f_G(~z9c=^-1_I4g(5K5|Ue!`9eR11l6 z+VmeGsGI-=@OhTm-e;9Q`wF(;D_l7%rc`QyV~iZpikQz8 z=^%^DCl#ZGDGfPJL_;N;CpC}eDOV+U3pRDQ5Uw80WpgvQS?XdnmvffVm8eYXVE3JLPTfd5dwDK0$*XtlAs?gCRmevWTf1h97oNZl97NM zg~yO%wsrIFU7I)W+P(R$@B90&f8Pg5r7vj?^^-mWf88m4Mty0HbeGf!nTRcPGi{U_ zp?9>O4Zs;S@gO6eKD5;gsfaCBvsMj@Ekc4}jD-Yg5H8>T;ylo;@5;Km>m zz=y%yl{SCX^w^&5QZ7AmgL2Z%pT0UL#P(l!XyeA6`#<^M@<00Fr4>N0^sP*KG%*b67~MLqH&e;&fpkTcfh6hVp}J zR{5!Ke2;wCy6v@Avzt5q9BqV{MP`7sT6$mFHMy&leSa&b0MBON%thdg2jo$h0 z!nC4;@l0^=Jj)Py;>CEt8YbRbbi82k)`(2YEF{3lw7vqCX3vjL*SqBuj z^4zJ&LL|W*)u4%xliU!t!V-wQGJ+hn$jlW7n9co=S6z7iy~ESiEPnYsZM#mz$NT?s z`GFm+_j50M*6f!m=<3Jk_iq(?{`S|0j&Za5uim?9{Z`a}(6K3?V-e(c&hZ94XVf`@ zf`il=PNj7O2M1+nbwR;A^?Kg(NuO2=eV#nYw>nxZyCQ?Mx?q153HMJi#(Sz#LgONV z9LT_2f#6hj;4c3J!NkDO9-6F&A*1GS$Y|j$BrwdFilZ2VdBs4;idp$!8bsY$n;@!0 zMzJ)8CXE^f(JZ?*@1+IJ`>P&a`qz`v4}F!Fmesvcv8%n|f#rWWP7NQ;>=O39F)nrE z9g8c%eB%H5LeJl$queeu>!90 z$%(cB#{&$HbuKAw*;GltnnOp z$KZiM3T_N|0j9$PhQ24R_5fKp4N1atOqpS_B|LoRdA-TLdgiQEAtwE~ltpnInK@?0zJYYmWDYc7c0c!WKwoZVAKYa7Z^+{0W~D~Fe-);tO|PjMQQ4H($tIX z!bmWpP;5n^eoGk(dh)R|6Fi_stKqd8rqw|%k<;m5T&Q4@2T2pPTE#gSrzd*qAo>g~ zI7u}u%^uOI^*9k!)}?hS66;#{>`NW+35uI^BLu&4a!iGuLXEc9M}vyAAeaU7!CFj0 zkJP3?%6W`-4mU^8*>vID2uRzE5F*thH4a_4J_*VclK8R0IQ3Y~DBWm%5hp8F}8Bz%Ions6F zuk#TiXe1jhgzJiRtGLy|N}UdD8fQ|Q)SjH5Is|5ABh?OF62u>~)y29pu8uRKV}(cp zg9(f$X1)g@ciwwaI{oN9=|QRCeR>UC>l<8Re@5Sz+y*Ffv!QOdXMJii+Zpq7TGd32 zw5l`E)k09i1RiSX_*5Z?q^dOX_;by3k=EZ-PLD(i>IwGH@eW;1m%S&2U~p5#?d&_- zzli%iU;$N<`~x5f4asr_sBu&<)X5Ar=I~kth)yUUOGNbW5LkmhQ3ChDv4DxZ!)i6? z7)~R>b9>?9OcD(_%+B^*1G($C@B4#=p4~sywD0C00LtkFSY2BQE9fc`yK}Y&>R_`sAcbpPW_-fz&Q6=hF-Hz&GDW#iD2PkA2O6^)0J7xJ*ccIP$Yq9FPQc zFl$%e*SL%$?!=zwK+l}JXVyVq6tHJ9UW6q$SX`2)c}mX^>OzQ~#5k$=n{PzVAO6-X z^4Rlac7O*z0anDv2{|n28>kjkP?3OM_S)-UCMfnCM!A>iYlo!=qz4bv*MRA7(QQ%# z7cE-_3G!zWt}K~efZ|x5aIu*F!sq}v2L&8(v!DR+weeTE>tZ>yjCX42QSuT`Q{}ZP z?5j79Og*G2ntI4sG`INAgui(b@Ph?Y;v8d19y1$NkzS_0yQO1dxwM6@0zJk&a~Qt{ zXMLpFIRd zECdsMxPX9JRtq>|P{lZBU|evVJuW0Jw2idUHm*(ErrYP;W^40l^KJ7p&UZO3wCPF7 zz*%?lWgJbCoti3X0{Ag+$iH)4;~)RSUCSSNmcI1TxaS+6e*LHad`~y+TyS!3`LW_{ zXU2!yxx_nGl&yH{=+-5m8u}0Fvg&%RnjU3s4$B;+%dy zP_5Nu(lmMPGIjYs>PxKFNj`c}^veze$`T+%L$#JeB%JRI%@e^&xw5E*-Uro@wQSkA z>Aw3mZQRoTNz|j|=f3#zeCe*3&Q31&?e{~X3`lobe*7WUw1jywy z;Nt+!`;u6vpMIMGUKF;?_oR0dGdF3vFxg;*R9Chita7_^4Q5Q!efMk01`Gg@kGx~b zV}(+m^Z|8H{Lw#!P~f-n1w3(BlALUoqet(dMH*~QXJ^c= z((_+_b*^l;WZJTE%v&LH_IRRF)3%72JrC=O@)UKc^ny+2O zx(FOYF8+AA(=;GJm0ZuD;*0w}Iq_`q$*RiJbETi8_o@Axx4-Y?AK0?-pqX1RM||)l;YRw=?^mIwf&%~xU73X#IN4KTym7p$0L){&36xOf^}FRkm8dg#cfo)fsSy#rMAT0b zt=5pqFj!#~M3$ZT%9UqZ#*|dw6>%~HfQtt%{!X6tlQjq z_4C~Q(-*Z(e0WRLBURmBebv3ZCAO1Gx$w?A7cRW_zI3@y>I?Aih>6;FNWFH!JUW)D zsG5$QIS1{%%sYRXcMu0^p#F)0Y%N{-M`0!`k|_r8OH1!qzpb+~{y^Q+PjManQ@D=S9WOrJzghI`e`4X{kCAJKK~|a2p9WSL zW1PO~4x;bYK1xoBTnEo`byO5`$yBWhDmhYNg(X!U`w6ba2S}fQ4Tf)6h6sbX=R35j zubNg#AJgE@PJUruY;!Zq;3h(niz7#+nam9R7$BcA#u+HU4umE(?O^6^!n6+`;)yXXHXeKiM$lqdVN`KPAS zZ|zwt{tTIr@YvAq_ zz__Z_zF<9k1Ygll<)e;d5kjPD92*DggDI+H^%Rz)nk~*&En}5@rC6z2%~lDk#nq|+ zoa+zC!}NC1PyQ}VqL4vdw6#n0>{~-GN^|T)$$^V9db5~IkuQn`u@1PN(=WHYyJ?(BEI{NoGKd-NmPa`!!ZE}ddO-VboA z0B#M8vrzK7Gs4Ge((o!0=r5|g^i6iw<$uc8tRfbZdYYJLnP$oh@R{b96=uHHmnvsz zEVPY8!RU-p#gVpJv}?zh?jDfabvFpfFgqn0iPLUfxnPcj_T;+0};;CmPv@=qrm~?CEw(p2(6s5x#mDpcEPv(JvB~5yaR5VsoCbN1?@R1#s;ty~YamZ@# z&~g;6qUrwoo3`J7|MoAxzy8&i*RQjW-haF2gAaP%et(bjSLq+1d2i8Z*uE4*V{nXj zNi+E(=okHEqBCH?Uv?RH(bMcyAo$8jvez6ENr2TI2qmy6D^aEr3u8bLZ;35dzVs5h z%+J3#SH6pWvssBNHgE4gD{7mk&yrq|zJf5~>@517E3`n2wn~M3Fsy!JWCIutL^fTf zUH+$iPX)?x%_N9$CJg%Up%@MI*fM z%}XzFBM}4e+5PuTpA8i{7V1sM&YIr*<8_Eqmx3m203KOLK4kn=I;hxUt;R0RDHS9% zi5hGl)TyCAg!IkpI6~r_4l}&F)oig7JGEQjZBI1O9A|M7C!J_^S_()3Eie~Ytn(qG zfqqlwp%NbQ8^+z0bFc&Wc49;3ouk?6m=W*3-v1WA@Pn1>LWiM!>;X*?0hH+vrK&bDP&mpC$|6-tsDaX&Sk7H}z~0Djo4$6TZ?_mVSJAI6T+Qd4Dg`QG(Xw^Cmq#;GK)p%<}(t9lxL?H(O=;t8Kk~nA`EwF`b zpR`~>!-bD8v|~sj{9ZcM+~0QhqMiHCa|@g41RV9iU4MST&qn<&Ej^`2KRyKj(iG|E0{s&VL!hLEP?FTuKZTc=5T~O;WuJ( zP0iFiFK`Zyb5G-GSm_CxMYB&xwO@nBFJcFOY6D#0AAb>W(Nl{vO9$>%tI=XMU#A7M zG?1eZ!S|{JKoXNVfFCAvY(tVcr+zD$142QUfvR+CY67dAl!T6w)Pb3{lJ9TQX?R^Q z38sOZ9}D1N4~)iN>!%CWhZ9JqbK$~pakwf>9i>mY`0rUk;N+zCy4T%C)(X!US%DkgA=movmHU zRSFf_HQYM3nqSA?CETrDr}Y88xpO}hb3YxY+aB9@xa(*kcbHsCC* zn(&lYgTy)45tpMDF`mKvgc8qO`QN90RPy>s5JW|)a$2dnlde{Yka1N(&AN6hKT11? zpQ%*?g&GcXJ93hTUm(@c&K_7Ac&UeWN;R+3;WUC@*#AX;Cw*B;<0f-H(lYumQd$At zV?9u6C2h_ugUx6_wb5}JJw|308|W;7Zy%pL|})HJD1Ta2eX zVEcmsv%prhHOH9c0lKYFX}*F9)0A6M;e&ZeEU*G*fbw8^W{efXH$UEdrbLphh zw4&jJ^uyS^yxj}B`Mkb|*m9)wJjm3{FM^o6*crfZB&cmbYz741ryxRuJQ7cHh?u2C zi|R@vV2Ve!pQ!b69%&5bk(^$m*%);eo1&h@iq&Oosk(vPrPdBfEq%hG``2S{-(23= zJZr}fkL~dF-?8V1=9y3jZF_5VVXyeVYU;4O;0W;b^D<$5lb=_Zl_!3|UgOO~$IFz% zUKDv+{adul3~|vPXG3$2wL;+1+#K)*x)q-yb0942a_07#b84#R&fK0k;l~5ZwmY5M zmmT58I2IcV7OcrM9`g^FVtk|VRult(@J%`i5U4d zUl>EW0Ah>?fJ`KWd6)W9FJVO}paipPjAJ5jbpTkek}FnW0l|h@5`Oj6=KMK#c= z3dzv>L!Dx)fxYIXx!-Ws9uOGdV-E>7Sj8YC1Z@7Kz{eyOSbe4j#9F6@gqlBuJT{~b z;J-4Xkf-iID)`jY&pvw_(j9Qc6@4fx5$=K>7)#23W#~5sV`|%Tqv1Z|eL)+8`DT5y zzR}QVYzz{>stpZBRZ!rA3rHA{qw*@XK8(yxbIvMGOPl=&7X3UlHodL3_HpMpdQhqT z5$B}Mo|T?fT-?{MW(6Uub7~)dyf){~VK=tQ)j+^aNPEgvHW4IT;U?_z2fq$?&VbFx zQ!N8NN4ogT6Dw`NXW&k@Y60Adcijq5?ps=*}yaMYLk3t%+Kz~Sx?BK zMvzS94%v>s@XRmoO#IC|Py;aJ8S@ZmJ8rp?Jmk*1L+_}>A$LA>-8l{1!MtDu$;K;? z6Tb}afI!?ZQ&%iwJ=t|4r1+ww!?Kt$(A5@-X7=&4giB+-f?s1 zmv`LUQSM+rZfI`qoCcZti^!eZT>ZGYBhT$*N(+C6!7uN)G5F;jHwMZb#J~;Bje&9p zF>v2;V<1PhG6uyz!{C>9+!*}wjvE8z4r1VjCSw4WZQsptum=R!yUe~-~dY!cR`%D*$tkd=Wt_53piVOwBxVWlJOklX%hRl??iu8u4=vdej zccgP;eoa+=!5u4vZ{lO3YcqcL;*rgpj;^mMC|F*dm%jpMqCL{9yaV!Io%mhydD%=%U%F=%wEAd`oeB>;m1Oz+}0Bzcz!gansT-5FkG z$DEww#T+80$`ciH%4bekH*wQCS|@GieESl6Uw!q1kJ7ga9i358&!2p+S&D6Mrx%;A zN;d+5tFPW1&+7rB1Tq2YCsMPAa8-_G zz=yha{Gs0*D6o{*+}-;^BEY}8{JrcYAbSAb-Udtbqr%yN>CGu6%ii!aUb=Vg{PAO7 zeX)MY-i`jH`B)&uxy6T9I|{-oXBz=sB^Fm%#5W;E18L@*;Zx-V39H*hupi zrWa@8z=1Tb`O+0wyKy-%%(bK)TzmI3&#t}uY3|0|Paj-!_cKppe6bWpA=cIzpl-+l zI=MyUj6^j{V6$jE?C<*!ww=f&+uaG*x*^!Yls*0-@x!=mdUE@T?eFx$j=P>8%f;Xy zKW2HB%bi_cAmrm4ty~Yq|4~fvw zVG*JjC=N4wM~mi6k{yS`^L5zcc}ZSa13}6D{tE1im3lDpggK&zOdVuV(!9gXrO}c$b#F&lwjZcRytKG2eCsYhB9{|7(? zcP`Ym<-qoAX4cP#+6LWxtyYtv*NWa6t@k@7&v%GL`*!-J;iM<&((tzeFHW<0n)H~L z(D*Sg^E|8HJT03$Nfl--9;XVM9UJ?Z^eJRlu#7tai~xk$IGsbTTro>uLooC`*vtxgjN-C|d0~JGs_C|O10^J=#G}#h!4+iWK&c7ru?`RCig(^$T;MS_ zyta8+{P^hPd%q|zpEG4j=DPRi%$YZL?%en9S^GZx%$qak{d<v*X;X7ws9gF& zZtm3FsZ(Fza~G9Onr{>)jyw8n!3gPHuA}IS(P?j5rvVN~t-BNzVi{P^1LU*W~FU*Q=ayF9@E;l|(X@b#;(dB1k>nRDKc z{~8mP{2IH!J`%Q*FNe{qf|nUpI7gd6?~I^!7PUrg)@alj7NdqylU2_I`i>R`x0l(3 zFAuO77V0buJ;?3cLjHC!womHq0j9_a19)2jxFYaJ18EpJ?=rN`64vj~2Ee-nV7Vep zenA3MQFiRB-Nzl-y7pl0p5*;d@xDL`pjQ^$1Vhl@MgM_`WGRTt0E_hjf0Z4D_(ERC z=YDM+-v}9g&9AQGV|@{K?G@?RZd}GkZ=WV)vj^bqQMfB-9@b|4jVG7YLJ3bx7p~VW5NnE&}dw)4hHGQ&|UmXd3M7*mCZiXg+uD z9NM{J;(#4Em%$38I_>as23Tt%ZKB?&ZL^AIwWk$c*Z^;r;M5wyMC1%4BxKM$!^$YQ zPu#vCdwGu#51R_=J5=B=Swu3hH#wx3+kAcP6X&JFot)Ue`iHeooTXDb`{AubbX<8) zd+$N%OvPIVdr=R-9KqYYV9$aFS>jAKIN;4K@Ub|ICZpM5G8thX8q>8}%oIvlRIQdn z>`w*_W>fTnQ45Jvky~ul8e`FazugV9UL|#O_3G7YIPZcbgdwR3Wl9A_hLAJGa7_NN zFlu8V7Je)2EKQW&fcIm3EVY$&(%q}hQP|4nDv77-r1fyp*T=wkLb>nFqx>P!26+;w z8zsw}V@D1ThYByk8v}#wo<=qzJczaW8C%0!{B}WwVU#`0GQtzmU(iAf46_UuM~Vry z(Uyd;q$s&^?xZ{e2IO5y31#6KQxzx8xIY!`rF;|jd14_0m^ez&)pL;jrLcKjUX_SY zMI?uFNw|U6+m>vjbwL}7c5l{d`!CZUeCuXDwn5;I4IlY^|LP;-o0lB6JHGF$dnRRD zDUHpWgXOW+TcZ2Va~E!#A$=%qDk$SVyG@e*fHkwX-F7~^FNcc1$GXwNg0oYQ2gAt? z{s2?XvPWs{ebTzU5)Mvm)9nLB>c+@kD^%JXC9!O`^0iA(Q^-8pyV!9UzH zy)iHScQe-Rf9!V)ws3V@N;fTE*4R+LY4OITRqOA(*|6?|wkI!@Zn%5d+kbrK%{q*I zA+neE%R>zhtTFp&KGCV#_)iQ1>{J)2pPCQQ6F;NY3@Wc+i~%DY1M+dnpgmMpA-NR5 zBJT#{N(Xk(L$Ur&>BV;G2+eJWoEZmiW+nVeJ`J+qS`rDnHRL^J^i%$ds!c7bcoM1M zB6Kou5`am#ArB%2d83(^02-Ubuf#2DeIGH{wnjTTXzl?zwexdH+Yb9R+>{JJhZH;1 zK8l|*fUcoxK2pUI89ER$2;IZsz^!Z;>=v`IzRT`iakS&B&pV|T4oF94;@&tpUjk#) zhpcmELXDe7uIJO>4}+YWC)T)mW^gLOtpD7qwF#elsTkQ}^r050xDyzx>!#|&GJ___ z+fqhSJxspHPlchqpw@DX02E&V*$lt z%%l%UHRq)}X!9KD{C|{6x&8|^tzk9&*EoGmSZfW?bXqFne-Albc%!Xzgokf1^A?## z&!|;wGHna+-bGHsVn~RuPGb+|h}FF&5+cvN+{rai!KexTFZQK~G;USxM zettn-Zb3ipwC=k3Ipo!&p=x|M8S6BXh!Bmx7~v(FLi|l$oz&pej?fQdunB9J&j=`E z`w-U8<%;nuaACu)r~!AH%ExFkR5%Rb4I5};*c6i~XL9oW!-mD( zUv}he>7$-U&R^bFcCT($e%1Dw1y$R*s#$-Sx_(1_RPcmFueoPe5;)x~8XnIcj$5pgdMBK+&$qaPHhK zyBTHi6>OjUo`@t$lW@e*T<+g}g`A`R1Gc+AjMGXzTj#M>R&aY$-(~FW5$G)idV_Z@ zy#xSFP93EE)O;f+HlkMrD+E&OPJk*s58Sx}pGVl^kM=(-<*N4mus{{`!#@y8!OizT zJ96Po5oyj4ou^UDTR7EMMsF+k75T#0>q&gPw6wyqgn2CSD#tZzoT34LQH!w>O)d&? zIY)>&hAIM-FklQ)z{hWoPc}uV!lpRxm?sq-Y36eu>UT~~6X-^Re#0T|VBciciMXtn zw)44AeBvPSFTp~q^)PIt{4=$J=kbFVJ*r?GOB1eLZ@V{eJs%DPV)YI9ln<|%{|3{j z1dq|lRurwvlA?uWuttDu*h))l!JGXnOjXw7>vM5tIWNX%BlD=De`A5wx__ zIa(tU-(a21D3Zwkgp;pr;r|xD)?4iV3cecfwdI?zmJ#8>p2VhMkr6%y%~IX6V7An= zas*&6S1HPGWKkjoJV90g3-fl_x88EaX&gZJM( zYjWj==H~bfh3i|69qd@ykhpeY=H|4{gZ<06J^iJ8L1vzFT610Cc*(gUJ!4D#`X+wP zys(gU0Rad5_41y`Ye3;;pb+07;*ab0e*f_SnylZDuk|efz9x;27t<^?En`c)Dj~xS z!T=;)6o5g;H`ojy3@+R)7LWu(6f4T>>dMO+>Xx*hKlgO|x${qRPxQ|d*8HFLzC6CE zD)0N8o13KB)1+zICQaI=`<5=WrL18Ste_PgifmFgMOkF0EFvO^wg?D{fFc7}&|y&7 zL_}}_*<~v7xS)bFE{~4lybg32Y18NXJ2$r$#OL$Q`~J&qPi}ITbIv{I-1FPN=h@oY zHP0=seRkUUeQ%sQ_r|{SO~X+e&OnCcN3}bFzSSiZh`Sv1FQ3Dz;s3S+3dLiMp5*dP z^4KQ3CYpfO>zSw>mxOVO(fO4fe@dl-oi4bG5D8gaQcP?E0~$g!P;fB6mIxpmF&Q}A zu8K>uC&0(=GH|#X&>AOCc;1Z$iDEog8S`_p3FmZpaZ;28Y6Y3E)9k5QHgT z%*mLNp^W;W2+oAyQZN2GU=(YA$WTyHP+Cw{&|V(OOGv~PFDSI;G-eXHHra}>48euC zgoA5F8#mX;xKjKW#AmeRFMM(4U3Uzr;6L`Os_M)C9(Hj)`hnZ#7nMEId%{ym84IhQ z-FW1{w2{NwKhmY&Bb^4%NlSj@u5HWt-admS-BrDiFKxGK;o|3Vmf8X-e_U2vyfrJQ z|E-mkTQ~h_$H18nus?luZcZ+EPkWLtATH5ox$TL1zupn(X?M80YC>3G$t5X-J>jDU~_iLFZktYNw z%03ZtW{NL>xw8p~W_C!EcsayC5i<{wq3}uJmil|4_5y!PQ9@iLlPlr(C8Z^ZQZJU$ zt`lwFBV9Up?3mp1y5aVrJG*ijP;^#A+(R-`u>UmZcORrhwump55!fw3AZY{rcaiLh zCBR;Yb{0FM0sTkVfAUA+@RclSDIXnP+dPS8j)8m%Y;(hyz;lwvik#F2nyB@*;RllNLgl=mLm}h}|@43Bw02l8R9N z;la1w5{ywsno~Gq1~j9xc;GBQy)qcq&1;lCpF5&CO?zO$zxQd%Q38Xl{T1lm0&H>U z)+l$PFA+}&w-By(`+SKI{HzwO!|Vo}g2_!#3h`#AQSajk#@$iQrH)@>ciW&?{YBoL zyw>K8O7$gr65`D!M6Vf{Ly5Wp@dtIGp-sR!~?LRho z6X!e}KDxAdVYu-dSL`N#^3$uNmzVO2SC2X{t_Si$^vb)SEM@GLPCe z(|FT*2a8{Cm9vx9mt?HZ_qH!A@Um=cdm)Ysu?n0sY^k4hBDftvbt1zULIlyp>l;>` z*E#1dhBEDUjIOsBW69`R5i!T!F|zR1B^9?l*?;)M+=MedAJ@G5vM|S{#B~g9>r@t- zB%4Y*h5zzO$M(gr)Vn)%+t#J5j7+o`&@I1!f_Y(2a#(g?21P z1KdmzHO#upT>Ec+g&}|n-a!y9C{ja=FU0J^5lzVW5d$h*5EOq2gmW3BWSyjI04UAU z@G|L3?b2T+$?skfUcWPdKH`uAC>QvTA-6#?$xV8;)hd~_24>VxH*45*EuqAbeOmAu z#D##S5I>6Pod7_Tozz#Th;lS*mAxD|5WX0`cz|!{&o{Jw74sI#9P(?KX01^p%G5@2 zvz|`}pE_OfXKwAmHf4$u5h6eZbLmljCY%Gs)ah^s^_v_B59=Qub^spl<^#WeMcX0> zMV`kAS4|Jj1={i`nQbs4S|(8&m1y9Jq<6=QPp^KEbZCe}Cnv&4s)W*`xTz^TMnPXA z1U5>rEGl+%vizo!9tXUr4wDO6ew8z1`Bl$oBWD!LFP$lh+#}9l^!Gt6-^Q$NM|4HU zkl(t>9Bo_`wb;#8nP27Z=qM@1X7a@uEG#d^r%ezDBABn~1y)>z2`>zccR`vfnb49P z$#`9(DS_pRw!@tvT7J8EWB8Lx7kQ@CAFz6T;QJGPwYK)v&M@5c>*jk39dI z@TPG6*YbR{nHBuYUctY_vi59jsJtjB_*!>*lBvC$CDr@zowtNM@+xmDdmdr*hFJUkeR;(=|O!~YEbb2ESR&W+1Tinr!u z_2}NS8%GEVg`#xn)}fbB3{~(w3|FwY)aY`AuKHf^v8_`%`P*@n*bOx7%@msV2~;xL!>?`0LBe~ zVzuH^^K8?>H6y|$;lry(Xbzv^4~8E;B|b5-DCed~&KdAH*KE|WU2q(VfEXs~$?k-| z6ZQ|^r$-QZ3;ZIeO$o(_H62=wyr~3T%=-jw_`djrPWTk^&J%e9iI8p7>_VofF^~}> z6$Q&LDkvSN+apy&yIg&zW+S6J@h<)rQ&B3U;v)qU2RM*D4XxG0$oq^ZlEO?5>!LuH z0d37^;Pu86i4Yb%&W8u_ZsWZm>PvwMT67P;a0y%ZK2rGb+Dn>G8aD_n(zI|u9-<>3 z89hr0MZ-B0AZ}3#C=HMwAV7=ARhoSvf)yC_(!Jq%d_IN0@QYz{*rJ`^bgJpFrd&?D za`wt;IS+Gz@ScO7JA(~T-gu^3@|9VFJajrm<^otu;GuI(WZ?f5zN3T{6W*2k%H1(~ zf^2>$At~15wr1v8;(Q)Mwi#ADmrd3fTKsMg!F^|FTCyy81^%qmB#YZ&P0mQw*<6ln zUmR?GY-X(0QKOrgnUo5>B_g>H%Sc}Dif&f03&b*rrfofm19VVLR|TJG%G?5;3?Qxg zh#rU(wIqO-Wt1szt!C7m!Gq?`9W;1OT>YSWU!u>yWmtXw;G%-z1)GM{`xE`j@8bMn z(t<&=XAc@O_d!0jerSE+(1N1DdG*6K6V~#^LG{H$^NWV&)!)4ZziE^WVoMM#Omr>* zm=|&r+p347?R1KD6q-QHNv#A;6Z{PYLk^peLyek)Rzo>xiC7^A6%z|ND0GQ$x*jzm z+84m=UWWGser)7r5Mzjy9M;`NZJjI~WNYQM#&_&yUA#fIz#Uk&LEpwJoV{Gpy%0-> z@E&1r5avWuv2^<82SOQExHpuIL5-L`$RU{QNuxt19$~ZB%-geP#?F!bq!oL@X?u3nugX8EegU=YUg6zLjk+qp|OIW)F3b{>K!weT^Q#&2LAzsIoWze zTYANcN|6nOCT*okR3kx*3OH3l)JD`NQWv=l0b+<0OADV>Y7+DBAGEVkl_hQJp?a2( zMaJ*Y9cT8a<5nY#trlORl z7%0W{Bv}qdd``&kM0lX^3FpE?_@*_Ie>L9(Ka}P#(c9liLFsGFaP*Vwb?D~!E=<@e z4l9NXd9nz6I4qn1WVp7-unF5SiS6Nh_wUVP*I>h9UWOY7P~pUkpS@E|%eWuj{{L@N za|B=RR0MlgPjd>a+|S@yY~ZOgSTXC0HPxnK6$L5H4}Pe#<%rXNq;LD5m zZ=v)u{gIpFH8)8e+VM>0wRfnzX;!<+kg+m$mRxC1smz~c_g027g9m>&s0tAR=Ud^p z#aOsdbOBlwF(61$g%MKV1lV=kkPUqs|Aw}3g>8@j-t~Rb+5IM)N9Puy>1#lqNj3b^JW~9%7BYLyt$%x^~hd5 zMppN#c>x!0sn?wDRb4F(%%sb}uh1Eho;a|Q@&0DP zro9C=Z5=FlW<*fHstqV>laA;EkvQxFq4zU-~$WoIBmACUYj8f$m$tR?gI zrAx@!uT9i!ho_*2y%9=g4!zYRbBEq$k{u`F_3{aq$!ml9U+=1n)mKKrDGMB!Y9Rbj z$gp^ETL0B5n1ylOE2`jy^NJEA4+FW4BIocM4TR$nvv{bhftihFli6&tne4V`o5SX` z#n@c7Sex76iD&WLWAvCjW{<^V_1HXiPqfG3ar$HYE`Mx-JKp1mZ*7JW*B%h6J_;x! z6;H8H2uh>MUCGw;RA~+$GdLrZhF_M9R6bYy(he$%aaP>EXr(t<{epqdJ8MU1R%jbB zCq)zA3~m^p)hCFTpw0qk)>#_R{F1hDC9Vx>vosrYeITK>e;ue98g!7Jy>3Nw@k&Nf zlAn>T{~{z*rFqZ-R?#w6xDYBW!;9Nim^h=}Ggq?Nj!In|>VJ{yPrIwTH%>f69PEvehajg4JRE+bNE}y- z6zd2mW(;AviYRh5v!9%gi|w<;KZIYBvS zvhYSaS;h{7&S=>S`4#B?Apr!oi$A@mZ`PEO&IA4V z`8L}^qp@me0dzH2&mul|!FzvnoOir6JcCf)mRDl2x#nliP7GfF^r6)8z6t9vHbit2#VEUATS<-qt^;6x z5UOn5ZKqIWlR4Jr)aYX5Xr{AS46)$6PBe8oQ3O>4k$akbMdUJB@FA_^)u7mAfYOLC zaa5!=hWSh-pDhBJJ649LMWUH`YQsbxB?Xr??>{>s{39rpK(G?@wKPIOqEJcFw48x< zLMMEl;a`AF&(6~hX9OmUxCg2>Y78{t2N8|KdCK?O9EM};rLt2zRbDII!Bn*B?If}R=9c?v8p>ZW**1CSP0%G%Iv z4!6_6nZ;_e%h43B2A9k@x62*lii>l1Pl%6m#W;1bK)PbFzB+Sioo=-`c5Sx96{pFF zamH$r4M6s_vE&Sgrf0IlAV5|`-wSaOQll_t|8RnsMGOt$$aAg25}Ia;@KXJFRCNxV zr?nYn8O822H`a<#3@vykG3iJr5ADA4^;cJ}oKFeZlKZ5Gzw`aL`|LcPoV+d2Kkv!a zD;GbuvV%7GVfc|F&_#aCGochTKv-IY6JMCFm?!$yR$$jJwX0WExR!f}k2U->ju z7FRhQMSiEq0#$w&aTjPu;-8k_t&GB3(ry=DQQe2GAJzTCHBsFP#`=E})vZ6; zy#2ai-LR`jd2)^Pk)ZC^u698Xsfv@(N6@u!EV8&w?kL|03Yj1B8VULr<`jhdYBd5Z zOb=j9ZqP|Wl@rmrV1}WojKk&%aRTTZz@i-%-Y}I9<9AODZ{S0w!e46>l*B{$uxa>B zAK^_i=o*yB2TIR^_c#aZO?fvH-f+f2>0q~qR~pZ34wzj)A&dRzOP@u%D_=Fz_iZ!8FtK;c-7^AFF^SH~ZfrAjd^Tl8hET||O zLq~aUB0$#^YDgSYNtx=?5(yc@Fw*nC@iondz8!u0sQ!hMx^}DS_{7$V85-;434g7g zRouC6YU*6Ccj5izGp13EZ<3a1o<)r_*^q94`C(2}&BcuPG;kBXS@2DVFkJ)OFHGPN zjLeHFI|EN+i3Y5E5EDNy-9Ar)B^t6&Z|J1K$ig3AsX4v&SO}_hiH0`jBQiH*RueBY zUhZFOFP$AWa{sFxCU@*LDR1=j3FEt03>`7ND))hoy`~i{-!f1h?iyD)XOSzW#*=V+ z&x*d|x^`;cHO^fV?U+8Y_fWjc9$-uk(or}Z=S z>X66JEs597Lty#}`jQ>V-Gs&@nk4XUz_(_QhXR$$01_l&Wc~k0Qy><50vHP`aO_JXXL_1xS zQP(@(;p~%!*9J70Rhh8?{SMuB<0{S5 zfz|DbGcyXa^5SB#aw9^c(^+1;#qG2fWjK9)ojb1`y);EXz${Dcf`4M&$SaT(u6T*i zY-l)@AvlBfD{wmCs-muLrHA9O5&(cNN(_LoX);ZqtQZ~&CGE;e%K~Mm3%KLlohvH3 zKY#0!+v50_g}@aDo-H3+7(VUZw&J$udh}WOhrfn@%-vQv4F)!xt1r~-(At^MTqajf_xe9{LAdGh{U49hDKuADHh9Hes0 zRL-@Ka%%b4N^qfc8?$kvWYiEQfgkVz>MBEkq_uH6NC$KjaY|yw`n_MT(Kd!JqZWQV z`*!Vj@J?(9`C{!r357wE0h8f`+w45yiSpUW+b=dwZ}5q!J;DZnnkI3_W zw?8h~#%&T-1(j`DB_l-@V2e{87toqoKj0Vq7E%Dv4TOpi(Eud!fY8}RQ~;fMs}3OE zZw_S6z2^_9oeRrj12%u=TxramDV?ir%IEOdzOKZ4hgA zWs5btY*_q2kuQy>>t3j@I}Q2LxP5yV*f-3>FUx~8_u<`*55bQLfe=`mfzzubrXZ5f zg$lPgPEN(O}g(o9WE3_)P z5)fY?qCyGfju@$c3vMJZ>L*JxHcXxRcz7;f5Wc`2+H=j{Ox(M-28*wZL~hUq=`ejtS&t5n6?sId+Eq(jldRyh~{qMN*4+E+O-Zg0OkfFow9$w8xj2tz3%suyx zz3={U<0njfVAA9%Q>RUzF|%gY>^XBEocGZDhZj7uaM7cSAA7vEZpjl%mo0yC#mc9i zUiHlCHEW-JZr$_i|F~h}rWfirZ+Y>hKW+WjB?0a+nfw$g% z=iP&c-aCBc=&|D`PQHKYFAeO2(;uGsua7?d&wypR^ah zd25gIB$z|6@$Qi;wz7@v5w?)M2}$N#wg^_;TJ{`!k!?b!Kh8b@uF(o`lRty=g4_?B zvCr8**gC9w|4)>5iEUtihWvP#ZDS+YNVbfP0`|ygc7z>cr`QSDa^GkF&Bm|~*k4!! zdzszCeqzhn8Frd|h`9Rifu8pmyN``!_XG279Gk$_vx#gHgP$v#!ltpQY&x64zGE}l zELOv2V}biQY!CY*n}^|^!?^zAz$*X?Gnv4i-&lkFnZ1NJa`hdmlO_a|C|PHbD)8thlI3*y&4yq+6s#P+7Iqwe326v^*CP$Y_Z3K^kiNt3 zF-QxM8j+qsdJKt?vOga`sqH<7w@q7;KDgS3thf~<2etZ!2eUQ)wK+09>`Zo6OBF&B@ z^*imiBke_k{|Q@7zpFvuHMCZ^(qWr$t--~n{>2tIx)dzdg22?Lf zRBw6?^_i&t3x6k3-fA7yJ=L#mQtL+bYn$kJ+q41o&cQLNH$QajzA7>hB69x{vw^ZBAoP+}ja*$`|>x z{DS=qB=Bl&G(%?@i z&tv)UuPH!0a}gxJcC3V9X-rrz%RvD<@^GtAa<nTzso>Po&Uq$UKY~JSWScN+*R#!R3+UQQ>`!bf zsMa>nqgU9gf-VpxAgZv3y$*`<2HOW}xSt(hZ?U&Q8{P%AIKjEg@KLlOPDrQ}3;L;NH;_tPhNyJa*!! zk)tO}9X)yUD7n|P$rH6BOWT!{(`RXc_$(Bk?dh{j94RXj-^;|Oa=b)*SF|>17%%j9 z3;O9e)>S(x&61W&Z%W^3N;M-i^E6Lk)%k<+qw;pGQ9D+?i}TO*7=thQ_N#AyIi-q7P;Pu zHO1Z;yVh-YSGec9566v*`!aq&{Ob5{f-7N8!oGx~o{^phJaavddscZid0zGG_Z;_p z?D^XBv!}&t_QreDy~W;;x1V>A_a5(5?|knQ-nHH>-d)~zyr;aMdB00^B~~VGPrTx* z^KJEg;;-{Mh`e{E7KX^4|=O4o(iv3)Tf!2kV17f^P*+20smc8@yP+ z3#yW#D| zxBGLu#u9T$uacQ14W;F!6{Ukq$CcKUE-GD7y1w+!rF%;cmws6KWm%W9JIltEU2Gq0 zKe;@r{Fd_C@(;>??2y{w)()eD#9+bOug81$fzv zT$X9wqN_H{Y8*4*GR$bQwzmu;bGW;*m+oLoq%lzvycU39j71jZhZuX=&XN@EBXa3J zcIp(AmvjZI283hy8vS?LizAkVfSzshA8f?Jm$<=pMPngng;)IE~5}L!7 zmeQ7%aA{Hd{sjdLnTZV?Hn#&cl4);jY6~!ei`CuO)D~bSJ(MIjHnjzq`9^!FZ9#ix ziGrH<#-_Fav)*VAwJm6mmK2qdnBdz@Ek1 zVEDhWsV%?~>{u4(#-_Fa^W10;wJm7RywTAt`o^ZV04Y)_UVwZcgl7rax4wGevA^GK l>vW0v5lDb-?^_qviv2s|v@MNTdG!IPZ6CGvje*jesGp7Im literal 0 HcmV?d00001 diff --git a/library/sdl/sdl-ttf.factor b/library/sdl/sdl-ttf.factor index a84417bb81..693fae82dd 100644 --- a/library/sdl/sdl-ttf.factor +++ b/library/sdl/sdl-ttf.factor @@ -78,6 +78,13 @@ USE: alien : TTF_FontFaceStyleName ( font -- n ) "char*" "sdl-ttf" "TTF_FontFaceStyleName" [ "void*" ] alien-invoke ; +BEGIN-STRUCT: int-box + FIELD: int i +END-STRUCT + +: TTF_SizeText ( font text w h -- ? ) + "bool" "sdl-ttf" "TTF_SizeText" [ "void*" "char*" "int-box*" "int-box*" ] alien-invoke ; + : TTF_RenderText_Solid ( font text fg -- surface ) "surface*" "sdl-ttf" "TTF_RenderText_Solid" [ "void*" "char*" "int" ] alien-invoke ; diff --git a/library/sdl/sdl-utils.factor b/library/sdl/sdl-utils.factor index 2e7f1b406c..0f3b252445 100644 --- a/library/sdl/sdl-utils.factor +++ b/library/sdl/sdl-utils.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2004 Slava Pestov. +! Copyright (C) 2004, 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -39,6 +39,9 @@ USE: prettyprint USE: sdl-event USE: sdl-gfx USE: sdl-video +USE: streams +USE: strings +USE: sdl-ttf SYMBOL: surface SYMBOL: width @@ -60,6 +63,14 @@ SYMBOL: surface swap 16 shift bitor swap 24 shift bitor ; +: make-color ( r g b -- color ) + #! Make an SDL_Color struct. This will go away soon in favor + #! of pass-by-value support in the FFI. + 255 24 shift + swap 16 shift bitor + swap 8 shift bitor + swap bitor ; + : black 0 0 0 ; : white 255 255 255 ; : red 255 0 0 ; @@ -98,3 +109,55 @@ SYMBOL: surface ] [ drop ] ifte ; + +SYMBOL: fonts + +: null? ( alien -- ? ) + dup [ alien-address 0 = ] when ; + +: ( name ptsize -- font ) + >r resource-path swap cat2 r> TTF_OpenFont ; + +: font ( name ptsize -- font ) + fonts get [ + 2dup cons get [ + 2nip + ] [ + 2dup cons >r dup r> set + ] ifte* + ] bind ; + +: make-rect ( x y w h -- rect ) + + [ set-rect-h ] keep + [ set-rect-w ] keep + [ set-rect-y ] keep + [ set-rect-x ] keep ; + +: surface-rect ( x y surface -- rect ) + dup surface-w swap surface-h make-rect ; + +: draw-surface ( x y surface -- ) + [ + [ surface-rect ] keep swap surface get 0 0 + ] keep surface-rect swap rot SDL_UpperBlit drop ; + +: draw-string ( x y font text fg bg -- width ) + pick str-length 0 = [ + 2drop 2drop 2drop 0 + ] [ + TTF_RenderText_Shaded + [ draw-surface ] keep + [ surface-w ] keep + SDL_FreeSurface + ] ifte ; + +: size-string ( font text -- w h ) + dup str-length 0 = [ + drop TTF_FontHeight 0 swap + ] [ + [ TTF_SizeText drop ] 2keep + swap int-box-i swap int-box-i + ] ifte ; + +global [ fonts set ] bind diff --git a/library/ui/console.factor b/library/ui/console.factor index 2c2ff83c1f..9418826963 100644 --- a/library/ui/console.factor +++ b/library/ui/console.factor @@ -63,6 +63,7 @@ USE: errors USE: line-editor USE: hashtables USE: lists +USE: sdl-ttf #! A namespace holding console state. SYMBOL: console @@ -78,13 +79,16 @@ SYMBOL: y SYMBOL: output-line #! A line editor object. SYMBOL: input-line +#! A TTF_Font* value. +SYMBOL: console-font +#! Font height. +SYMBOL: line-height #! The font size is hardcoded here. -: line-height 8 ; : char-width 8 ; ! Scrolling -: visible-lines ( -- n ) height get line-height /i ; +: visible-lines ( -- n ) height get line-height get /i ; : total-lines ( -- n ) lines get vector-length ; : available-lines ( -- ) total-lines first-line get - ; @@ -105,19 +109,20 @@ SYMBOL: input-line total-lines fix-first-line first-line set ; ! Rendering -: background white rgb ; -: foreground black rgb ; -: cursor red rgb ; +: background white ; +: foreground black ; +: cursor red ; : next-line ( -- ) - 0 x set line-height y [ + ] change ; + 0 x set line-height get y [ + ] change ; : draw-line ( str -- ) - [ surface get x get y get ] keep foreground stringColor - str-length char-width * x [ + ] change ; + >r x get y get console-font get r> + foreground make-color background make-color draw-string + x [ + ] change ; : clear-display ( -- ) - surface get 0 0 width get height get background boxColor ; + surface get 0 0 width get height get background rgb boxColor ; : draw-lines ( -- ) visible-lines available-lines min [ @@ -133,14 +138,17 @@ SYMBOL: input-line swap y get over 1 + - y get line-height + - cursor boxColor ; + y get line-height get + + cursor rgb boxColor ; : draw-current ( -- ) output-line get sbuf>str draw-line ; : caret-x ( -- x ) - x get input-line get [ caret get char-width * + ] bind ; + x get input-line get [ + console-font get caret get line-text get str-head + size-string drop + + ] bind ; : draw-input ( -- ) caret-x >r @@ -341,7 +349,13 @@ M: alien handle-event ( event -- ? ) drop t ] ifte ; +: set-console-font ( font ptsize ) + font dup console-font set + TTF_FontHeight line-height set ; + : init-console ( -- ) + TTF_Init + "/fonts/VeraMono.ttf" 14 set-console-font event set 0 first-line set 80 lines set From af40535556fbffc528c7ae6b075303c75f47b0a3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Jan 2005 02:31:32 +0000 Subject: [PATCH 033/122] more descriptive undefined-method error --- library/errors.factor | 5 +++++ library/generic/generic.factor | 17 +++++++++-------- library/inference/words.factor | 1 + library/syntax/prettyprint.factor | 6 +++++- library/tools/debugger.factor | 10 ++++++++++ 5 files changed, 30 insertions(+), 9 deletions(-) diff --git a/library/errors.factor b/library/errors.factor index ad0109c116..00def19460 100644 --- a/library/errors.factor +++ b/library/errors.factor @@ -37,6 +37,11 @@ USE: namespaces USE: strings USE: vectors +: undefined-method ( object generic -- ) + #! This word is redefined in tools/debugger.factor with a + #! more useful definition once unparse is available. + "No suitable method" throw ; + ! This is a very lightweight exception handling system. : catchstack ( -- cs ) 6 getenv ; diff --git a/library/generic/generic.factor b/library/generic/generic.factor index abfe9ee63e..24cac9d733 100644 --- a/library/generic/generic.factor +++ b/library/generic/generic.factor @@ -38,6 +38,7 @@ USE: words USE: vectors USE: math USE: math-internals +USE: unparser ! A simple single-dispatch generic word system. @@ -64,9 +65,6 @@ USE: math-internals ! Metaclasses have priority -- this induces an order in which ! methods are added to the vtable. -: undefined-method - "No applicable method." throw ; - : metaclass ( class -- metaclass ) "metaclass" word-property ; @@ -94,14 +92,17 @@ USE: math-internals #! Add the method entry to the vtable. Unlike define-method, #! this is called at vtable build time, and in the sorted #! order. - dup metaclass "add-method" word-property - [ [ undefined-method ] ] unless* call ; + dup metaclass "add-method" word-property [ + [ "Metaclass is missing add-method" throw ] + ] unless* call ; -: ( -- vtable ) - num-types [ drop [ undefined-method ] ] vector-project ; +: ( generic -- vtable ) + unit num-types + [ drop dup [ car undefined-method ] cons ] vector-project + nip ; : ( generic -- vtable ) - over methods [ + dup over methods [ ( generic vtable method ) >r 2dup r> unswons add-method ] each nip ; diff --git a/library/inference/words.factor b/library/inference/words.factor index 6af8a9336f..21b1f3f50f 100644 --- a/library/inference/words.factor +++ b/library/inference/words.factor @@ -204,5 +204,6 @@ M: symbol (apply-word) ( word -- ) \ - [ [ number number ] [ number ] ] "infer-effect" set-word-property \ undefined-method t "terminator" set-word-property +\ undefined-method [ [ object word ] [ ] ] "infer-effect" set-word-property \ not-a-number t "terminator" set-word-property \ throw t "terminator" set-word-property diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index 15fefa4794..f067f7d7ed 100644 --- a/library/syntax/prettyprint.factor +++ b/library/syntax/prettyprint.factor @@ -121,7 +121,11 @@ M: word prettyprint* ( indent word -- indent ) [ prettyprint-element ] each ; M: list prettyprint* ( indent list -- indent ) - swap prettyprint-[ swap prettyprint-list prettyprint-] ; + [ + swap prettyprint-[ swap prettyprint-list prettyprint-] + ] [ + f unparse write + ] ifte* ; M: cons prettyprint* ( indent cons -- indent ) \ [[ prettyprint* " " write diff --git a/library/tools/debugger.factor b/library/tools/debugger.factor index 3c3931c0aa..2218c6d12b 100644 --- a/library/tools/debugger.factor +++ b/library/tools/debugger.factor @@ -175,6 +175,16 @@ M: object error. ( error -- ) [ dup save-error rethrow ] 5 setenv ( kernel calls on error ) kernel-error 12 setenv ; +: undefined-method ( object generic -- ) + #! We 2dup here to leave both values on the stack, for + #! post-mortem inspection. + 2dup [ + "The generic word " , + unparse , + " does not have a suitable method for " , + unparse , + ] make-string throw ; + ! So that stage 2 boot gives a useful error message if something ! fails after this file is loaded. init-error-handler From 4a6f404cc293be1b05176b7d3b5ff8c56c7d4fb5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Jan 2005 02:53:55 +0000 Subject: [PATCH 034/122] better plugin tools --- TODO.FACTOR.txt | 2 -- actions.xml | 8 ++------ factor/jedit/CompileBufferProcessor.java | 15 ++------------- factor/jedit/FactorBufferProcessor.java | 10 +++++++--- factor/jedit/InferBufferProcessor.java | 9 ++++----- 5 files changed, 15 insertions(+), 29 deletions(-) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 48a4af52ad..c7c527da70 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -27,12 +27,10 @@ + listener/plugin: - update plugin docs -- extract word puts stuff in the wrong place - extract word keeps indent - word preview for remote words - WordPreview calls markTokens() -> NPE - listener should be multithreaded -- compile all commands - faster completion - NPE in ErrorHighlight - maple-like: press enter at old commands to evaluate there diff --git a/actions.xml b/actions.xml index b70bc9b67c..654f989e9f 100644 --- a/actions.xml +++ b/actions.xml @@ -94,16 +94,12 @@ - InferBufferProcessor.createInferUnitTests(view,buffer, - FactorPlugin.getExternalInstance()); + InferBufferProcessor.createInferUnitTests(view,buffer); - wm.showDockableWindow("console"); - CompileBufferProcessor.compileWordsInBuffer(view,buffer, - FactorPlugin.getExternalInstance(), - wm.getDockableWindow("console")); + new CompileBufferProcessor(view,buffer); diff --git a/factor/jedit/CompileBufferProcessor.java b/factor/jedit/CompileBufferProcessor.java index 36f5f3d0d0..2272c56068 100644 --- a/factor/jedit/CompileBufferProcessor.java +++ b/factor/jedit/CompileBufferProcessor.java @@ -38,22 +38,11 @@ import org.gjt.sp.util.*; public class CompileBufferProcessor extends FactorBufferProcessor { - //{{{ compileWordsInBuffer() method - public static void compileWordsInBuffer(View view, - Buffer buffer, - ExternalFactor factor, - Output output) throws Exception - { - String results = new CompileBufferProcessor( - buffer,factor).getResults(); - output.print(null,results); - } //}}} - //{{{ CompileBufferProcessor constructor - public CompileBufferProcessor(Buffer buffer, ExternalFactor factor) + public CompileBufferProcessor(View view, Buffer buffer) throws Exception { - super(buffer,factor); + super(view,buffer,true); } //}}} //{{{ processWord() method diff --git a/factor/jedit/FactorBufferProcessor.java b/factor/jedit/FactorBufferProcessor.java index 9333c6e976..961586c208 100644 --- a/factor/jedit/FactorBufferProcessor.java +++ b/factor/jedit/FactorBufferProcessor.java @@ -31,6 +31,7 @@ package factor.jedit; import factor.*; import org.gjt.sp.jedit.Buffer; +import org.gjt.sp.jedit.View; /** * A class used to compile all words in a file, or infer stack effects of all @@ -41,8 +42,8 @@ public abstract class FactorBufferProcessor private String results; //{{{ FactorBufferProcessor constructor - public FactorBufferProcessor(Buffer buffer, ExternalFactor factor) - throws Exception + public FactorBufferProcessor(View view, Buffer buffer, + boolean evalInListener) throws Exception { StringBuffer buf = new StringBuffer(); @@ -56,7 +57,10 @@ public abstract class FactorBufferProcessor buf.append("! "); buf.append(expr); buf.append('\n'); - buf.append(factor.eval(expr)); + if(evalInListener) + FactorPlugin.evalInListener(view,expr); + else + buf.append(FactorPlugin.evalInWire(expr)); words = words.next(); } diff --git a/factor/jedit/InferBufferProcessor.java b/factor/jedit/InferBufferProcessor.java index f1042ae5ce..cccfcff160 100644 --- a/factor/jedit/InferBufferProcessor.java +++ b/factor/jedit/InferBufferProcessor.java @@ -44,11 +44,10 @@ public class InferBufferProcessor extends FactorBufferProcessor { //{{{ createInferUnitTests() method public static void createInferUnitTests(View view, - final Buffer buffer, - final ExternalFactor factor) + final Buffer buffer) throws Exception { - final String results = new InferBufferProcessor(buffer,factor) + final String results = new InferBufferProcessor(view,buffer) .getResults(); final Buffer newBuffer = jEdit.newFile(view); @@ -70,10 +69,10 @@ public class InferBufferProcessor extends FactorBufferProcessor } //}}} //{{{ InferBufferProcessor constructor - public InferBufferProcessor(Buffer buffer, ExternalFactor factor) + public InferBufferProcessor(View view, Buffer buffer) throws Exception { - super(buffer,factor); + super(view,buffer,false); } //}}} //{{{ processWord() method From 0dfb0cf01e4d4274f8b9f8389e54cb0d616ec516 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 26 Jan 2005 00:40:57 +0000 Subject: [PATCH 035/122] array refactoring; started hashtable refactoring --- Makefile | 4 +- TODO.FACTOR.txt | 6 ++- examples/grad-demo.factor | 45 +++++++++++++++++ examples/mandel.factor | 10 ++-- library/arrays.factor | 53 ++++++++++++++++++++ library/bootstrap/boot-stage2.factor | 1 + library/bootstrap/boot.factor | 1 + library/bootstrap/init-stage2.factor | 1 - library/bootstrap/primitives.factor | 2 - library/hashtables.factor | 29 ++++++----- library/inference/branches.factor | 4 +- library/inference/types.factor | 18 +++---- library/kernel.factor | 6 +-- library/namespaces.factor | 5 ++ library/primitives.factor | 4 +- library/test/vectors.factor | 8 +++ library/ui/console.factor | 28 ++++++----- library/vectors.factor | 73 +++++++++++++++++++--------- native/array.h | 12 ----- native/gc.c | 2 +- native/image.c | 4 +- native/memory.c | 1 + native/primitives.c | 2 - native/primitives.h | 2 +- native/unix/signal.c | 2 + native/vector.c | 41 ---------------- native/vector.h | 3 -- 27 files changed, 230 insertions(+), 137 deletions(-) create mode 100644 examples/grad-demo.factor create mode 100644 library/arrays.factor diff --git a/Makefile b/Makefile index 417c47a299..879eca23bc 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ CC = gcc -DEFAULT_CFLAGS = -Wall -g $(SITE_CFLAGS) +DEFAULT_CFLAGS = -Wall -Os -fomit-frame-pointer $(SITE_CFLAGS) DEFAULT_LIBS = -lm STRIP = strip @@ -68,7 +68,7 @@ solaris: f: $(OBJS) $(CC) $(LIBS) $(CFLAGS) -o $@ $(OBJS) - #$(STRIP) $@ + $(STRIP) $@ clean: rm -f $(OBJS) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index c7c527da70..3ec887c84f 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -17,6 +17,9 @@ + ffi: +- value type structs +- unicode strings +- out parameters - figure out how to load an image referring to missing libraries - is signed -vs- unsigned pointers an issue? - bitfields in C structs @@ -49,13 +52,12 @@ + kernel: - ppc register decls -- do partial objects cause problems? -- remove sbufs - cat, reverse-cat primitives - first-class hashtables + misc: +- make-vector and make-string should not need a reverse step - perhaps /i should work with all numbers - jedit ==> jedit-word, jedit takes a file name - browser responder for word links in HTTPd diff --git a/examples/grad-demo.factor b/examples/grad-demo.factor new file mode 100644 index 0000000000..efacf32e31 --- /dev/null +++ b/examples/grad-demo.factor @@ -0,0 +1,45 @@ +! Gradient rendering demo. +! +! To run this code, bootstrap Factor like so: +! +! ./f boot.image.le32 +! -libraries:sdl:name=libSDL.so +! -libraries:sdl-gfx:name=libSDL_gfx.so +! -libraries:sdl-ttf:name=libSDL_ttf.so +! +! (But all on one line) +! +! Then, start Factor as usual (./f factor.image) and enter this +! at the listener: +! +! "examples/grad-demo.factor" run-file + +IN: grad-demo +USE: streams +USE: sdl +USE: sdl-event +USE: sdl-gfx +USE: sdl-video +USE: sdl-ttf +USE: namespaces +USE: math +USE: kernel +USE: test +USE: compiler +USE: strings +USE: alien +USE: prettyprint +USE: lists + +: draw-grad ( -- ) + [ over rgb ] with-pixels ; compiled + +: grad-demo ( -- ) + 640 480 0 SDL_HWSURFACE [ + TTF_Init + [ draw-grad ] with-surface + event-loop + SDL_Quit + ] with-screen ; + +grad-demo diff --git a/examples/mandel.factor b/examples/mandel.factor index a4384c2878..5ee2fcaf6f 100644 --- a/examples/mandel.factor +++ b/examples/mandel.factor @@ -32,7 +32,7 @@ USE: test : scale 255 * >fixnum ; -: scale-rgb ( r g b -- n ) +: scale-rgb ( r g b a -- n ) scale swap scale 8 shift bitor swap scale 16 shift bitor @@ -44,10 +44,10 @@ USE: test : ( nb-cols -- map ) [ dup [ - dup 360 * over 1 + / 360 / sat val + dup 360 * pick 1 + / 360 / sat val hsv>rgb 1.0 scale-rgb , ] repeat - ] make-list list>vector nip ; + ] make-vector nip ; : absq >rect swap sq swap sq + ; inline @@ -72,7 +72,7 @@ SYMBOL: center height get 150000 zoom-fact get * / y-inc set nb-iter get max-color min cols set ; -: c ( #{ i j }# -- c ) +: c ( i j -- c ) >r x-inc get * center get real x-inc get width get 2 / * - + >float r> @@ -89,7 +89,7 @@ SYMBOL: center ] with-pixels ; compiled : mandel ( -- ) - 640 480 32 SDL_HWSURFACE [ + 640 480 0 SDL_HWSURFACE [ [ 0.8 zoom-fact set -0.65 center set diff --git a/library/arrays.factor b/library/arrays.factor new file mode 100644 index 0000000000..3026f58f4c --- /dev/null +++ b/library/arrays.factor @@ -0,0 +1,53 @@ +! :folding=none:collapseFolds=1: + +! $Id$ +! +! Copyright (C) 2005 Slava Pestov. +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, +! this list of conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, +! this list of conditions and the following disclaimer in the documentation +! and/or other materials provided with the distribution. +! +! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, +! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; +! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +IN: kernel-internals +USE: generic +USE: math-internals +USE: kernel + +! An array is a range of memory storing pointers to other +! objects. Arrays are not used directly, and their access words +! are not bounds checked. Examples of abstractions built on +! arrays include vectors, hashtables, and tuples. + +! These words are unsafe. I'd say "do not call them", but that +! Java-esque. By all means, do use arrays if you need something +! low-level... but be aware that vectors are usually a better +! choice. + +BUILTIN: array 8 + +: array-capacity ( array -- n ) 1 integer-slot ; inline +: vector-array ( vec -- array ) 2 slot ; inline +: set-vector-array ( array vec -- ) 2 set-slot ; inline + +: array-nth ( n array -- obj ) + swap 2 fixnum+ slot ; inline + +: set-array-nth ( obj n array -- ) + swap 2 fixnum+ set-slot ; inline diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index 2456ed93f7..fdd77c2046 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -48,6 +48,7 @@ USE: namespaces "/version.factor" "/library/stack.factor" "/library/combinators.factor" + "/library/arrays.factor" "/library/kernel.factor" "/library/cons.factor" "/library/assoc.factor" diff --git a/library/bootstrap/boot.factor b/library/bootstrap/boot.factor index 49a272f6c5..d991caa709 100644 --- a/library/bootstrap/boot.factor +++ b/library/bootstrap/boot.factor @@ -42,6 +42,7 @@ USE: hashtables "/version.factor" parse-resource append, "/library/stack.factor" parse-resource append, "/library/combinators.factor" parse-resource append, + "/library/arrays.factor" parse-resource append, "/library/kernel.factor" parse-resource append, "/library/cons.factor" parse-resource append, "/library/assoc.factor" parse-resource append, diff --git a/library/bootstrap/init-stage2.factor b/library/bootstrap/init-stage2.factor index edf3b32046..32a38e6ac1 100644 --- a/library/bootstrap/init-stage2.factor +++ b/library/bootstrap/init-stage2.factor @@ -114,6 +114,5 @@ unparse write " words total" print ! Save a bit of space global [ stdio off ] bind -garbage-collection "factor.image" save-image 0 exit* diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor index 2017b45a23..0b45a454ae 100644 --- a/library/bootstrap/primitives.factor +++ b/library/bootstrap/primitives.factor @@ -59,8 +59,6 @@ vocabularies get [ [[ "kernel" "ifte" ]] [[ "lists" "cons" ]] [[ "vectors" "" ]] - [[ "vectors" "vector-nth" ]] - [[ "vectors" "set-vector-nth" ]] [[ "strings" "str-nth" ]] [[ "strings" "str-compare" ]] [[ "strings" "str=" ]] diff --git a/library/hashtables.factor b/library/hashtables.factor index 33e65a94cf..9750f2430e 100644 --- a/library/hashtables.factor +++ b/library/hashtables.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2004 Slava Pestov. +! Copyright (C) 2004, 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -25,13 +25,24 @@ ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -IN: hashtables +IN: kernel-internals USE: generic USE: kernel USE: lists USE: math USE: vectors +: hash-array vector-array ; inline +: bucket-count >vector hash-array array-capacity ; inline + +: hash-bucket ( n hash -- alist ) + swap >fixnum swap >vector hash-array array-nth ; inline + +: set-hash-bucket ( obj n hash -- ) + >r >fixnum r> hash-array set-array-nth ; inline + +IN: hashtables + ! Note that the length of a hashtable vector must not change ! for the lifetime of the hashtable, otherwise problems will ! occur. Do not use vector words with hashtables. @@ -48,13 +59,13 @@ PREDICATE: vector hashtable ( obj -- ? ) : (hashcode) ( key table -- index ) #! Compute the index of the bucket for a key. - >r hashcode r> vector-length rem ; inline + >r hashcode r> bucket-count rem ; inline : hash* ( key table -- [[ key value ]] ) #! Look up a value in the hashtable. First the bucket is #! determined using the hash function, then the association #! list therein is searched linearly. - 2dup (hashcode) swap vector-nth assoc* ; + 2dup (hashcode) swap hash-bucket assoc* ; : hash ( key table -- value ) #! Unlike hash*, this word cannot distinglish between an @@ -67,9 +78,9 @@ PREDICATE: vector hashtable ( obj -- ? ) 2dup (hashcode) r> pick >r over >r - >r swap vector-nth r> call + >r swap hash-bucket r> call r> - r> set-vector-nth ; inline + r> set-hash-bucket ; inline : set-hash ( value key table -- ) #! Store the value in the hashtable. Either replaces an @@ -85,12 +96,6 @@ PREDICATE: vector hashtable ( obj -- ? ) #! Apply the code to each key/value pair of the hashtable. swap [ swap dup >r each r> ] vector-each drop ; inline -: hash-subset ( hash code -- hash ) - #! Return a new hashtable containing all key/value pairs - #! for which the predicate yielded a true value. The - #! predicate must have stack effect ( obj -- ? ). - swap [ swap dup >r subset r> swap ] vector-map nip ; inline - : hash-keys ( hash -- list ) #! Push a list of keys in a hashtable. [ ] swap [ car swons ] hash-each ; diff --git a/library/inference/branches.factor b/library/inference/branches.factor index c54e1c07a8..d78fe2a164 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -73,7 +73,7 @@ USE: prettyprint : unify-stacks ( list -- stack ) #! Replace differing literals in stacks with unknown #! results. - unify-lengths vector-transpose [ unify-results ] vector-map ; + unify-lengths vector-transpose [ unify-results ] vector-map ; : balanced? ( list -- ? ) #! Check if a list of [[ instack outstack ]] pairs is @@ -104,7 +104,7 @@ USE: prettyprint ] unless* ; : unify-effects ( list -- ) - filter-terminators dup datastack-effect callstack-effect ; + filter-terminators dup datastack-effect callstack-effect ; SYMBOL: cloned diff --git a/library/inference/types.factor b/library/inference/types.factor index 5e6b19d114..7acdc8e7b8 100644 --- a/library/inference/types.factor +++ b/library/inference/types.factor @@ -63,15 +63,15 @@ USE: prettyprint \ >string \ string infer-check ] "infer" set-word-property -\ slot [ - [ object fixnum ] ensure-d - dataflow-drop, pop-d literal-value - peek-d value-class builtin-supertypes dup length 1 = [ - cons \ slot [ [ object ] [ object ] ] (consume/produce) - ] [ - "slot called without static type knowledge" throw - ] ifte -] "infer" set-word-property +! \ slot [ +! [ object fixnum ] ensure-d +! dataflow-drop, pop-d literal-value +! peek-d value-class builtin-supertypes dup length 1 = [ +! cons \ slot [ [ object ] [ object ] ] (consume/produce) +! ] [ +! "slot called without static type knowledge" throw +! ] ifte +! ] "infer" set-word-property : type-value-map ( value -- ) num-types [ dup builtin-type pick swons cons ] project diff --git a/library/kernel.factor b/library/kernel.factor index fe37533502..fb3c4544af 100644 --- a/library/kernel.factor +++ b/library/kernel.factor @@ -31,9 +31,9 @@ USE: kernel USE: vectors : dispatch ( n vtable -- ) - #! This word is unsafe in compiled code since n is not - #! bounds-checked. Do not call it directly. - vector-nth call ; + #! This word is unsafe since n is not bounds-checked. Do not + #! call it directly. + vector-array array-nth call ; IN: kernel diff --git a/library/namespaces.factor b/library/namespaces.factor index e1632b9c47..362f0f3754 100644 --- a/library/namespaces.factor +++ b/library/namespaces.factor @@ -153,6 +153,11 @@ SYMBOL: list-buffer #! was called. make-rlist reverse ; inline +: make-vector ( quot -- list ) + #! Return a vector whose entries are in the same order that + #! , was called. + make-list list>vector ; inline + : , ( obj -- ) #! Append an object to the currently constructing list. list-buffer cons@ ; diff --git a/library/primitives.factor b/library/primitives.factor index b37e757da9..14fe6e7421 100644 --- a/library/primitives.factor +++ b/library/primitives.factor @@ -55,8 +55,6 @@ USE: words [ ifte [ [ object general-list general-list ] [ ] ] ] [ cons [ [ object object ] [ cons ] ] ] [ [ [ integer ] [ vector ] ] ] - [ vector-nth [ [ integer vector ] [ object ] ] ] - [ set-vector-nth [ [ object integer vector ] [ ] ] ] [ str-nth [ [ integer string ] [ integer ] ] ] [ str-compare [ [ string string ] [ integer ] ] ] [ str= [ [ string string ] [ boolean ] ] ] @@ -222,7 +220,7 @@ USE: words [ set-slot [ [ object object fixnum ] [ ] ] ] [ integer-slot [ [ object fixnum ] [ integer ] ] ] [ set-integer-slot [ [ integer object fixnum ] [ ] ] ] - [ grow-array [ [ integer array ] [ integer ] ] ] + [ grow-array [ [ integer array ] [ object ] ] ] ] [ 2unlist dup string? [ "stack-effect" set-word-property diff --git a/library/test/vectors.factor b/library/test/vectors.factor index 0b901472e3..8a8afb976c 100644 --- a/library/test/vectors.factor +++ b/library/test/vectors.factor @@ -6,10 +6,12 @@ USE: test USE: vectors USE: strings USE: namespaces +USE: kernel-internals [ [ t f t ] vector-length ] unit-test-fails [ 3 ] [ { t f t } vector-length ] unit-test +[ -3 { } vector-nth ] unit-test-fails [ 3 { } vector-nth ] unit-test-fails [ 3 #{ 1 2 }# vector-nth ] unit-test-fails @@ -74,3 +76,9 @@ unit-test [ "funny-stack" get vector-pop ] unit-test-fails [ ] [ "funky" "funny-stack" get vector-push ] unit-test [ "funky" ] [ "funny-stack" get vector-pop ] unit-test + +[ t ] [ + 10 dup vector-array array-capacity + >r vector-clone vector-array array-capacity r> + = +] unit-test diff --git a/library/ui/console.factor b/library/ui/console.factor index 9418826963..1b97d2bfaf 100644 --- a/library/ui/console.factor +++ b/library/ui/console.factor @@ -83,6 +83,9 @@ SYMBOL: input-line SYMBOL: console-font #! Font height. SYMBOL: line-height +#! If this is on, the console will be redrawn on the next event +#! refresh cycle. +SYMBOL: redraw-console #! The font size is hardcoded here. : char-width 8 ; @@ -174,8 +177,10 @@ SYMBOL: line-height 0 y set clear-display draw-lines - draw-current - draw-input + height get y get - line-height get >= [ + draw-current + draw-input + ] when draw-scrollbar ] with-surface ; @@ -186,7 +191,7 @@ SYMBOL: line-height lines get vector-push scroll-to-bottom ; : console-write ( text -- ) - "\n" split1 [ + "\n" split1 [ swap output-line get sbuf-append output-line get empty-buffer add-line ] when* @@ -215,7 +220,7 @@ M: console-stream fflush ( stream -- ) M: console-stream fauto-flush ( stream -- ) [ - console get [ draw-console ] bind + console get [ redraw-console on ] bind ] bind ; M: console-stream freadln ( stream -- line ) @@ -280,10 +285,10 @@ SYMBOL: keymap M: key-down-event handle-event ( event -- ? ) dup keyboard-event>binding keymap get hash [ - call draw-console + call redraw-console on ] [ dup input-key? [ - keyboard-event-unicode user-input draw-console + keyboard-event-unicode user-input redraw-console on ] [ drop ] ifte @@ -296,10 +301,10 @@ SYMBOL: drag-start-line : scrollbar-click ( y -- ) dup scrollbar-top < [ - drop page-scroll-up draw-console + drop page-scroll-up redraw-console on ] [ dup scrollbar-bottom > [ - drop page-scroll-down draw-console + drop page-scroll-down redraw-console on ] [ drag-start-y set first-line get drag-start-line set @@ -323,7 +328,7 @@ M: motion-event handle-event ( event -- ? ) motion-event-y drag-start-y get - height get / total-lines * drag-start-line get + >fixnum fix-first-line first-line set - draw-console + redraw-console on ] [ drop ] ifte t ; @@ -332,7 +337,7 @@ M: resize-event handle-event ( event -- ? ) dup resize-event-w swap resize-event-h 0 SDL_HWSURFACE SDL_RESIZABLE bitor init-screen scroll-to-bottom - draw-console t ; + redraw-console on t ; M: quit-event handle-event ( event -- ? ) drop f ; @@ -366,6 +371,7 @@ M: alien handle-event ( event -- ? ) SDL_EnableKeyRepeat drop ; : console-loop ( -- ) + redraw-console get [ draw-console redraw-console off ] when check-event [ console-loop ] when ; : console-quit ( -- ) @@ -395,7 +401,7 @@ IN: shells ] callcc0 console get [ - draw-console + redraw-console on console-loop console-quit ] bind diff --git a/library/vectors.factor b/library/vectors.factor index ffa7ce67d8..48f149c7ad 100644 --- a/library/vectors.factor +++ b/library/vectors.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2004 Slava Pestov. +! Copyright (C) 2004, 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -25,41 +25,66 @@ ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +IN: vectors USE: generic USE: kernel USE: lists USE: math - -IN: errors -DEFER: throw - -IN: kernel-internals - -BUILTIN: array 8 - -! UNSAFE! -: array-capacity ( array -- n ) 1 integer-slot ; inline -: vector-array ( vec -- array ) 2 slot ; inline -: set-vector-array ( array vec -- ) 2 set-slot ; inline - -: grow-vector-array ( len vec -- ) - [ vector-array grow-array ] keep set-vector-array ; inline - -: (set-vector-length) ( len vec -- ) 1 set-integer-slot ; inline - -IN: vectors +USE: kernel-internals +USE: errors +USE: math-internals BUILTIN: vector 11 : vector-length ( vec -- len ) >vector 1 integer-slot ; inline -: set-vector-length ( len vec -- ) - >vector over 0 < [ - "Vector length must be positive" throw 2drop +IN: kernel-internals + +: (set-vector-length) ( len vec -- ) 1 set-integer-slot ; inline + +: assert-positive ( fx -- ) + 0 fixnum< + [ "Vector index must be positive" throw ] when ; inline + +: assert-bounds ( fx vec -- ) + over assert-positive + vector-length fixnum>= + [ "Vector index out of bounds" throw ] when ; inline + +: grow-capacity ( len vec -- ) + #! If the vector cannot accomodate len elements, resize it + #! to exactly len. + [ vector-array grow-array ] keep set-vector-array ; inline + +: ensure-capacity ( n vec -- ) + #! If n is beyond the vector's length, increase the length, + #! growing the array if necessary, with an optimistic + #! doubling of its size. + 2dup vector-length fixnum>= [ + >r 1 fixnum+ r> + 2dup vector-array array-capacity fixnum> [ + over 2 fixnum* over grow-capacity + ] when + (set-vector-length) ] [ - 2dup (set-vector-length) grow-vector-array + 2drop ] ifte ; inline +IN: vectors + +: vector-nth ( n vec -- obj ) + swap >fixnum swap >vector + 2dup assert-bounds vector-array array-nth ; + +: set-vector-nth ( obj n vec -- ) + swap >fixnum dup assert-positive swap >vector + 2dup ensure-capacity vector-array + set-array-nth ; + +: set-vector-length ( len vec -- ) + swap >fixnum dup assert-positive swap >vector + 2dup grow-capacity (set-vector-length) ; + : empty-vector ( len -- vec ) #! Creates a vector with 'len' elements set to f. Unlike #! , which gives an empty vector with a certain diff --git a/native/array.h b/native/array.h index 74d56506e7..acc77a0991 100644 --- a/native/array.h +++ b/native/array.h @@ -21,17 +21,5 @@ F_ARRAY* shrink_array(F_ARRAY* array, CELL capacity); #define ASIZE(pointer) align8(sizeof(F_ARRAY) + \ ((F_ARRAY*)(pointer))->capacity * CELLS) -/* untagged & unchecked */ -INLINE CELL array_nth(F_ARRAY* array, CELL index) -{ - return get(AREF(array,index)); -} - -/* untagged & unchecked */ -INLINE void set_array_nth(F_ARRAY* array, CELL index, CELL value) -{ - put(AREF(array,index),value); -} - void fixup_array(F_ARRAY* array); void collect_array(F_ARRAY* array); diff --git a/native/gc.c b/native/gc.c index 784677928c..b075429cad 100644 --- a/native/gc.c +++ b/native/gc.c @@ -119,7 +119,7 @@ void primitive_gc(void) fflush(stderr); flip_zones(); - scan = active.here = active.base; + scan = active.base; collect_roots(); collect_io_tasks(); /* collect literal objects referenced from compiled code */ diff --git a/native/image.c b/native/image.c index 75cd0bd0ef..650d8e67d8 100644 --- a/native/image.c +++ b/native/image.c @@ -115,6 +115,8 @@ bool save_image(char* filename) void primitive_save_image(void) { - F_STRING* filename = untag_string(dpop()); + F_STRING* filename; + primitive_gc(); + filename = untag_string(dpop()); save_image(to_c_string(filename)); } diff --git a/native/memory.c b/native/memory.c index 8173732863..62e10b63dc 100644 --- a/native/memory.c +++ b/native/memory.c @@ -87,6 +87,7 @@ void flip_zones() ZONE z = active; active = prior; prior = z; + active.here = active.base; } bool in_zone(ZONE* z, CELL pointer) diff --git a/native/primitives.c b/native/primitives.c index dd7d6a652a..07dd50f034 100644 --- a/native/primitives.c +++ b/native/primitives.c @@ -9,8 +9,6 @@ void* primitives[] = { primitive_ifte, primitive_cons, primitive_vector, - primitive_vector_nth, - primitive_set_vector_nth, primitive_string_nth, primitive_string_compare, primitive_string_eq, diff --git a/native/primitives.h b/native/primitives.h index 60736374aa..353fbfe10a 100644 --- a/native/primitives.h +++ b/native/primitives.h @@ -1,4 +1,4 @@ extern void* primitives[]; -#define PRIMITIVE_COUNT 195 +#define PRIMITIVE_COUNT 194 CELL primitive_to_xt(CELL primitive); diff --git a/native/unix/signal.c b/native/unix/signal.c index 40818072c2..d65acfe7c1 100644 --- a/native/unix/signal.c +++ b/native/unix/signal.c @@ -9,6 +9,8 @@ void signal_handler(int signal, siginfo_t* siginfo, void* uap) fprintf(stderr,"active.here = %ld\n",active.here); fprintf(stderr,"active.limit = %ld\n",active.limit); fflush(stderr); + flip_zones(); + dump_stacks(); exit(1); } else diff --git a/native/vector.c b/native/vector.c index 921ea3444d..2b2e4a6866 100644 --- a/native/vector.c +++ b/native/vector.c @@ -22,47 +22,6 @@ void primitive_to_vector(void) type_check(VECTOR_TYPE,dpeek()); } -void primitive_vector_nth(void) -{ - F_VECTOR* vector = untag_vector(dpop()); - CELL index = to_fixnum(dpop()); - - if(index < 0 || index >= vector->top) - range_error(tag_object(vector),0,tag_fixnum(index),vector->top); - dpush(array_nth(untag_array(vector->array),index)); -} - -void vector_ensure_capacity(F_VECTOR* vector, CELL index) -{ - F_ARRAY* array = untag_array(vector->array); - CELL capacity = array->capacity; - if(index >= capacity) - array = grow_array(array,index * 2 + 1,F); - vector->top = index + 1; - vector->array = tag_object(array); -} - -void primitive_set_vector_nth(void) -{ - F_VECTOR* vector; - F_FIXNUM index; - CELL value; - - maybe_garbage_collection(); - - vector = untag_vector(dpop()); - index = to_fixnum(dpop()); - value = dpop(); - - if(index < 0) - range_error(tag_object(vector),0,tag_fixnum(index),vector->top); - else if(index >= vector->top) - vector_ensure_capacity(vector,index); - - /* the following does not check bounds! */ - set_array_nth(untag_array(vector->array),index,value); -} - void fixup_vector(F_VECTOR* vector) { data_fixup(&vector->array); diff --git a/native/vector.h b/native/vector.h index a851779c16..cffc5a7ff4 100644 --- a/native/vector.h +++ b/native/vector.h @@ -17,8 +17,5 @@ F_VECTOR* vector(F_FIXNUM capacity); void primitive_vector(void); void primitive_to_vector(void); -void primitive_vector_nth(void); -void vector_ensure_capacity(F_VECTOR* vector, CELL index); -void primitive_set_vector_nth(void); void fixup_vector(F_VECTOR* vector); void collect_vector(F_VECTOR* vector); From 67af634d00eb4f59d5f3416e07d6a76e12e937b7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 28 Jan 2005 01:06:10 +0000 Subject: [PATCH 036/122] hashtables bootstrap correctly --- Makefile | 3 +- library/arrays.factor | 14 ++++- library/bootstrap/image.factor | 41 ++++++++------ library/bootstrap/primitives.factor | 3 + library/generic/traits.factor | 4 +- library/hashtables.factor | 85 +++++++++++++++++++---------- library/namespaces.factor | 2 +- library/primitives.factor | 6 +- library/test/hashtables.factor | 14 +++++ library/test/vectors.factor | 2 +- library/vectors.factor | 15 ++--- native/array.c | 29 +++++++--- native/array.h | 9 +-- native/factor.h | 1 + native/gc.c | 3 + native/gc.h | 3 + native/hashtable.c | 33 +++++++++++ native/hashtable.h | 15 +++++ native/primitives.c | 5 +- native/relocate.c | 3 + native/s48_bignumint.h | 2 +- native/stack.c | 4 +- native/types.c | 3 + native/types.h | 1 + native/vector.c | 2 +- native/vector.h | 2 +- 26 files changed, 225 insertions(+), 79 deletions(-) create mode 100644 native/hashtable.c create mode 100644 native/hashtable.h diff --git a/Makefile b/Makefile index 879eca23bc..76102d6865 100644 --- a/Makefile +++ b/Makefile @@ -24,7 +24,8 @@ OBJS = native/arithmetic.o native/array.o native/bignum.o \ native/unix/read.o \ native/unix/write.o \ native/unix/ffi.o \ - native/debug.o + native/debug.o \ + native/hashtable.o default: @echo "Run 'make' with one of the following parameters:" diff --git a/library/arrays.factor b/library/arrays.factor index 3026f58f4c..0e052d9b7c 100644 --- a/library/arrays.factor +++ b/library/arrays.factor @@ -29,6 +29,7 @@ IN: kernel-internals USE: generic USE: math-internals USE: kernel +USE: lists ! An array is a range of memory storing pointers to other ! objects. Arrays are not used directly, and their access words @@ -42,7 +43,7 @@ USE: kernel BUILTIN: array 8 -: array-capacity ( array -- n ) 1 integer-slot ; inline +: array-capacity ( array -- n ) 1 slot ; inline : vector-array ( vec -- array ) 2 slot ; inline : set-vector-array ( array vec -- ) 2 set-slot ; inline @@ -51,3 +52,14 @@ BUILTIN: array 8 : set-array-nth ( obj n array -- ) swap 2 fixnum+ set-slot ; inline + +: (array>list) ( n i array -- list ) + pick pick fixnum<= [ + 3drop [ ] + ] [ + 2dup array-nth >r >r 1 fixnum+ r> (array>list) r> + swap cons + ] ifte ; + +: array>list ( n array -- list ) + 0 swap (array>list) ; diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index 9b4e47857b..3115837abc 100644 --- a/library/bootstrap/image.factor +++ b/library/bootstrap/image.factor @@ -41,6 +41,7 @@ IN: image USE: errors USE: generic +USE: kernel-internals USE: hashtables USE: kernel USE: lists @@ -86,12 +87,12 @@ SYMBOL: boot-quot : cons-tag BIN: 010 ; inline : object-tag BIN: 011 ; inline -: f-type 6 ; inline -: t-type 7 ; inline -: array-type 8 ; inline -: vector-type 11 ; inline -: string-type 12 ; inline -: word-type 17 ; inline +: t-type 7 ; inline +: array-type 8 ; inline +: hashtable-type 10 ; inline +: vector-type 11 ; inline +: string-type 12 ; inline +: word-type 17 ; inline : immediate ( x tag -- tagged ) swap tag-bits shift bitor ; : >header ( id -- tagged ) object-tag immediate ; @@ -142,6 +143,8 @@ GENERIC: ' ( obj -- ptr ) ( Fixnums ) +: emit-fixnum ( n -- ) fixnum-tag immediate emit ; + M: fixnum ' ( n -- tagged ) fixnum-tag immediate ; ( Bignums ) @@ -154,7 +157,7 @@ M: bignum ' ( bignum -- tagged ) [[ 0 [ 1 0 ] ]] [[ -1 [ 2 1 1 ] ]] [[ 1 [ 2 0 1 ] ]] - ] assoc [ emit ] each align-here r> ; + ] assoc unswons emit-fixnum [ emit ] each align-here r> ; ( Special objects ) @@ -175,7 +178,7 @@ M: f ' ( obj -- ptr ) : -1, -1 >bignum ' drop ; ( Beginning of the image ) -! The image proper begins with the header, then T, +! The image begins with the header, then T, ! and the bignums 0, 1, and -1. : begin ( -- ) header t, 0, 1, -1, ; @@ -249,7 +252,7 @@ M: cons ' ( c -- tagged ) object-tag here-as swap string-type >header emit dup str-length emit - dup hashcode fixnum-tag immediate emit + dup hashcode emit-fixnum pack-string align-here ; @@ -266,7 +269,7 @@ M: string ' ( string -- pointer ) [ ' ] map object-tag here-as >r array-type >header emit - dup length emit + dup length emit-fixnum ( elements -- ) [ emit ] each align-here r> ; @@ -274,7 +277,7 @@ M: string ' ( string -- pointer ) dup vector>list emit-array swap vector-length object-tag here-as >r vector-type >header emit - emit ( length ) + emit-fixnum ( length ) emit ( array ptr ) align-here r> ; @@ -284,24 +287,30 @@ M: vector ' ( vector -- pointer ) : rehash ( hashtable -- ) ! Now make a rehashing boot quotation dup hash>alist [ - >r dup vector-length [ - [ f swap pick set-vector-nth ] keep - ] repeat r> + over hash-clear [ unswons rot set-hash ] each-with ] cons cons boot-quot [ append ] change ; +: emit-hashtable ( hash -- pointer ) + dup buckets>list emit-array swap hash-size + object-tag here-as >r + hashtable-type >header emit + emit-fixnum ( length ) + emit ( array ptr ) + align-here r> ; + M: hashtable ' ( hashtable -- pointer ) #! Only hashtables are pooled, not vectors! dup pooled-object [ - [ dup emit-vector [ pool-object ] keep ] keep rehash + [ dup emit-hashtable [ pool-object ] keep ] keep rehash ] ?unless ; ( End of the image ) : vocabularies, ( vocabularies -- ) [ - cdr dup vector? [ + cdr dup hashtable? [ [ cdr dup word? [ word, ] [ drop ] ifte ] hash-each diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor index 0b45a454ae..8484cc844a 100644 --- a/library/bootstrap/primitives.factor +++ b/library/bootstrap/primitives.factor @@ -218,11 +218,14 @@ vocabularies get [ [[ "vectors" ">vector" ]] [[ "strings" ">string" ]] [[ "words" ">word" ]] + [[ "hashtables" ">hashtable" ]] [[ "kernel-internals" "slot" ]] [[ "kernel-internals" "set-slot" ]] [[ "kernel-internals" "integer-slot" ]] [[ "kernel-internals" "set-integer-slot" ]] [[ "kernel-internals" "grow-array" ]] + [[ "hashtables" "" ]] + [[ "kernel-internals" "" ]] ] [ unswons create swap 1 + [ f define ] keep ] each drop diff --git a/library/generic/traits.factor b/library/generic/traits.factor index 3240fb16f0..2bafb8053c 100644 --- a/library/generic/traits.factor +++ b/library/generic/traits.factor @@ -39,7 +39,7 @@ USE: vectors ! Traits metaclass for user-defined classes based on hashtables : traits ( object -- symbol ) - dup vector? [ \ traits swap hash ] [ drop f ] ifte ; + dup hashtable? [ \ traits swap hash ] [ drop f ] ifte ; ! Hashtable slot holding an optional delegate. Any undefined ! methods are called on the delegate. The object can also @@ -58,7 +58,7 @@ SYMBOL: delegate ] ifte ; : add-traits-dispatch ( word vtable -- ) - >r unit [ car traits-dispatch call ] cons \ vector r> + >r unit [ car traits-dispatch call ] cons \ hashtable r> set-vtable ; \ traits [ diff --git a/library/hashtables.factor b/library/hashtables.factor index 9750f2430e..1bcc3fe9d1 100644 --- a/library/hashtables.factor +++ b/library/hashtables.factor @@ -25,37 +25,45 @@ ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -IN: kernel-internals +IN: hashtables USE: generic USE: kernel USE: lists USE: math USE: vectors -: hash-array vector-array ; inline -: bucket-count >vector hash-array array-capacity ; inline +BUILTIN: hashtable 10 + +! A hashtable is implemented as an array of buckets. The +! array index is determined using a hash function, and the +! buckets are associative lists which are searched +! linearly. + +IN: kernel-internals + +: hash-array 2 slot ; inline : hash-bucket ( n hash -- alist ) - swap >fixnum swap >vector hash-array array-nth ; inline + swap >fixnum swap >hashtable hash-array array-nth ; inline : set-hash-bucket ( obj n hash -- ) - >r >fixnum r> hash-array set-array-nth ; inline + swap >fixnum swap >hashtable hash-array set-array-nth ; + inline + +: hash-size+ ( hash -- ) + >hashtable dup 1 slot 1 + swap 1 set-slot ; inline + +: hash-size- ( hash -- ) + >hashtable dup 1 slot 1 - swap 1 set-slot ; inline IN: hashtables -! Note that the length of a hashtable vector must not change -! for the lifetime of the hashtable, otherwise problems will -! occur. Do not use vector words with hashtables. +: hash-size ( hash -- n ) + #! Number of elements in the hashtable. + >hashtable 1 slot ; -PREDICATE: vector hashtable ( obj -- ? ) - [ assoc? ] vector-all? ; - -: ( buckets -- ) - #! A hashtable is implemented as an array of buckets. The - #! array index is determined using a hash function, and the - #! buckets are associative lists which are searched - #! linearly. The number of buckets must be a power of two. - empty-vector ; +: bucket-count ( hash -- n ) + >hashtable hash-array array-capacity ; inline : (hashcode) ( key table -- index ) #! Compute the index of the bucket for a key. @@ -74,6 +82,8 @@ PREDICATE: vector hashtable ( obj -- ? ) : set-hash* ( key table quot -- ) #! Apply the quotation to yield a new association list. + #! If the association list already contains the key, + #! decrement the hash size, since it will get removed. >r 2dup (hashcode) r> pick >r @@ -86,27 +96,46 @@ PREDICATE: vector hashtable ( obj -- ? ) #! Store the value in the hashtable. Either replaces an #! existing value in the appropriate bucket, or adds a new #! key/value pair. + dup hash-size+ [ set-assoc ] set-hash* ; : remove-hash ( key table -- ) #! Remove a value from a hashtable. [ remove-assoc ] set-hash* ; -: hash-each ( hash code -- ) - #! Apply the code to each key/value pair of the hashtable. - swap [ swap dup >r each r> ] vector-each drop ; inline +: hash-clear ( hash -- ) + #! Remove all entries from a hashtable. + dup bucket-count [ + [ f swap pick set-hash-bucket ] keep + ] repeat drop ; + +: buckets>list ( hash -- list ) + #! Push a list of key/value pairs in a hashtable. + dup bucket-count swap hash-array array>list ; + +: (hash>alist) ( alist n hash -- alist ) + 2dup bucket-count >= [ + 2drop + ] [ + [ hash-bucket [ swons ] each ] 2keep + >r 1 + r> (hash>alist) + ] ifte ; + +: hash>alist ( hash -- alist ) + #! Push a list of key/value pairs in a hashtable. + [ ] 0 rot (hash>alist) ; + +: alist>hash ( alist -- hash ) + dup length swap [ unswons pick set-hash ] each ; : hash-keys ( hash -- list ) #! Push a list of keys in a hashtable. - [ ] swap [ car swons ] hash-each ; + hash>alist [ car ] map ; : hash-values ( hash -- alist ) #! Push a list of values in a hashtable. - [ ] swap [ cdr swons ] hash-each ; + hash>alist [ cdr ] map ; -: hash>alist ( hash -- list ) - #! Push a list of key/value pairs in a hashtable. - [ ] swap [ swons ] hash-each ; - -: alist>hash ( alist -- hash ) - 37 swap [ unswons pick set-hash ] each ; +: hash-each ( hash code -- ) + #! Apply the code to each key/value pair of the hashtable. + >r hash>alist r> each ; inline diff --git a/library/namespaces.factor b/library/namespaces.factor index 362f0f3754..32cad49a1a 100644 --- a/library/namespaces.factor +++ b/library/namespaces.factor @@ -61,7 +61,7 @@ USE: math : >n ( namespace -- n:namespace ) #! Push a namespace on the namespace stack. - >vector namestack cons set-namestack ; inline + >hashtable namestack cons set-namestack ; inline : n> ( n:namespace -- namespace ) #! Pop the top of the namespace stack. diff --git a/library/primitives.factor b/library/primitives.factor index 14fe6e7421..d0484b0f98 100644 --- a/library/primitives.factor +++ b/library/primitives.factor @@ -26,6 +26,7 @@ ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. IN: alien +USE: hashtables DEFER: alien DEFER: dll @@ -215,12 +216,15 @@ USE: words [ >cons [ [ object ] [ cons ] ] ] [ >vector [ [ object ] [ vector ] ] ] [ >string [ [ object ] [ string ] ] ] - [ >word [ [ word ] [ word ] ] ] + [ >word [ [ object ] [ word ] ] ] + [ >hashtable [ [ object ] [ hashtable ] ] ] [ slot [ [ object fixnum ] [ object ] ] ] [ set-slot [ [ object object fixnum ] [ ] ] ] [ integer-slot [ [ object fixnum ] [ integer ] ] ] [ set-integer-slot [ [ integer object fixnum ] [ ] ] ] [ grow-array [ [ integer array ] [ object ] ] ] + [ [ [ number ] [ hashtable ] ] ] + [ [ [ number ] [ array ] ] ] ] [ 2unlist dup string? [ "stack-effect" set-word-property diff --git a/library/test/hashtables.factor b/library/test/hashtables.factor index 77cf386e86..37e74d53d7 100644 --- a/library/test/hashtables.factor +++ b/library/test/hashtables.factor @@ -58,3 +58,17 @@ f 100000000000000000000000000 "testhash" get set-hash "visual basic" "testhash" get remove-hash "visual basic" "testhash" get hash* ] unit-test + +[ 4 ] [ + "hey" + {{ [[ "hey" 4 ]] [[ "whey" 5 ]] }} 2dup (hashcode) + >r buckets>list r> [ cdr ] times car assoc +] unit-test + +! Testing the hash element counting + + "counting" set +"key" "value" "counting" get set-hash +[ 1 ] [ "counting" get hash-size ] unit-test +"key" "value" "counting" get set-hash +[ 1 ] [ "counting" get hash-size ] unit-test diff --git a/library/test/vectors.factor b/library/test/vectors.factor index 8a8afb976c..d55b1fe168 100644 --- a/library/test/vectors.factor +++ b/library/test/vectors.factor @@ -78,7 +78,7 @@ unit-test [ "funky" ] [ "funny-stack" get vector-pop ] unit-test [ t ] [ - 10 dup vector-array array-capacity + { 1 2 3 4 } dup vector-array array-capacity >r vector-clone vector-array array-capacity r> = ] unit-test diff --git a/library/vectors.factor b/library/vectors.factor index 48f149c7ad..57124a65cd 100644 --- a/library/vectors.factor +++ b/library/vectors.factor @@ -36,11 +36,11 @@ USE: math-internals BUILTIN: vector 11 -: vector-length ( vec -- len ) >vector 1 integer-slot ; inline +: vector-length ( vec -- len ) >vector 1 slot ; inline IN: kernel-internals -: (set-vector-length) ( len vec -- ) 1 set-integer-slot ; inline +: (set-vector-length) ( len vec -- ) 1 set-slot ; inline : assert-positive ( fx -- ) 0 fixnum< @@ -107,15 +107,8 @@ IN: vectors : >pop> ( stack -- stack ) dup vector-pop drop ; -: (vector>list) ( i vec -- list ) - 2dup vector-length >= [ - 2drop [ ] - ] [ - 2dup vector-nth >r >r 1 + r> (vector>list) r> swons - ] ifte ; - -: vector>list ( str -- list ) - 0 swap (vector>list) ; +: vector>list ( vec -- list ) + dup vector-length swap vector-array array>list ; : vector-each ( vector quotation -- ) #! Execute the quotation with each element of the vector diff --git a/native/array.c b/native/array.c index 2531fa9754..191d234470 100644 --- a/native/array.c +++ b/native/array.c @@ -5,7 +5,7 @@ F_ARRAY* allot_array(CELL type, CELL capacity) { F_ARRAY* array; array = allot_object(type,sizeof(F_ARRAY) + capacity * CELLS); - array->capacity = capacity; + array->capacity = tag_fixnum(capacity); return array; } @@ -22,20 +22,30 @@ F_ARRAY* array(CELL capacity, CELL fill) return array; } +void primitive_array(void) +{ + F_FIXNUM capacity = to_fixnum(dpop()); + if(capacity < 0) + general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_fixnum(capacity)); + maybe_garbage_collection(); + dpush(tag_object(array(capacity,F))); +} + F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill) { /* later on, do an optimization: if end of array is here, just grow */ int i; F_ARRAY* new_array; + CELL curr_cap = untag_fixnum_fast(array->capacity); - if(array->capacity >= capacity) + if(curr_cap >= capacity) return array; new_array = allot_array(untag_header(array->header),capacity); memcpy(new_array + 1,array + 1,array->capacity * CELLS); - for(i = array->capacity; i < capacity; i++) + for(i = curr_cap; i < capacity; i++) put(AREF(new_array,i),fill); return new_array; @@ -43,8 +53,11 @@ F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill) void primitive_grow_array(void) { - F_ARRAY* array = untag_array(dpop()); - CELL capacity = to_fixnum(dpop()); + F_ARRAY* array; + CELL capacity; + maybe_garbage_collection(); + array = untag_array(dpop()); + capacity = to_fixnum(dpop()); dpush(tag_object(grow_array(array,capacity,F))); } @@ -58,13 +71,15 @@ F_ARRAY* shrink_array(F_ARRAY* array, CELL capacity) void fixup_array(F_ARRAY* array) { int i = 0; - for(i = 0; i < array->capacity; i++) + CELL capacity = untag_fixnum_fast(array->capacity); + for(i = 0; i < capacity; i++) data_fixup((void*)AREF(array,i)); } void collect_array(F_ARRAY* array) { int i = 0; - for(i = 0; i < array->capacity; i++) + CELL capacity = untag_fixnum_fast(array->capacity); + for(i = 0; i < capacity; i++) copy_object((void*)AREF(array,i)); } diff --git a/native/array.h b/native/array.h index acc77a0991..28d71a4b41 100644 --- a/native/array.h +++ b/native/array.h @@ -1,17 +1,18 @@ typedef struct { CELL header; - /* untagged */ + /* tagged */ CELL capacity; } F_ARRAY; INLINE F_ARRAY* untag_array(CELL tagged) { - /* type_check(ARRAY_TYPE,tagged); */ - return (F_ARRAY*)UNTAG(tagged); /* FIXME */ + type_check(ARRAY_TYPE,tagged); + return (F_ARRAY*)UNTAG(tagged); } F_ARRAY* allot_array(CELL type, CELL capacity); F_ARRAY* array(CELL capacity, CELL fill); +void primitive_array(void); F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill); void primitive_grow_array(void); F_ARRAY* shrink_array(F_ARRAY* array, CELL capacity); @@ -19,7 +20,7 @@ F_ARRAY* shrink_array(F_ARRAY* array, CELL capacity); #define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS) #define ASIZE(pointer) align8(sizeof(F_ARRAY) + \ - ((F_ARRAY*)(pointer))->capacity * CELLS) + untag_fixnum_fast(((F_ARRAY*)(pointer))->capacity) * CELLS) void fixup_array(F_ARRAY* array); void collect_array(F_ARRAY* array); diff --git a/native/factor.h b/native/factor.h index 2c1d399f40..49f7ed2a60 100644 --- a/native/factor.h +++ b/native/factor.h @@ -135,6 +135,7 @@ typedef unsigned char BYTE; #include "image.h" #include "primitives.h" #include "vector.h" +#include "hashtable.h" #include "stack.h" #include "compiler.h" #include "relocate.h" diff --git a/native/gc.c b/native/gc.c index b075429cad..5e2c880970 100644 --- a/native/gc.c +++ b/native/gc.c @@ -71,6 +71,9 @@ INLINE void collect_object(CELL scan) case ARRAY_TYPE: collect_array((F_ARRAY*)scan); break; + case HASHTABLE_TYPE: + collect_hashtable((F_HASHTABLE*)scan); + break; case VECTOR_TYPE: collect_vector((F_VECTOR*)scan); break; diff --git a/native/gc.h b/native/gc.h index 50664383fb..1c03e41e48 100644 --- a/native/gc.h +++ b/native/gc.h @@ -27,6 +27,9 @@ INLINE void copy_object(CELL* handle) if(tag == FIXNUM_TYPE) return; + if(headerp(pointer)) + critical_error("Asked to copy header",pointer); + header = get(UNTAG(pointer)); if(TAG(header) == GC_COLLECTED) newpointer = UNTAG(header); diff --git a/native/hashtable.c b/native/hashtable.c new file mode 100644 index 0000000000..cb27bd4c01 --- /dev/null +++ b/native/hashtable.c @@ -0,0 +1,33 @@ +#include "factor.h" + +F_HASHTABLE* hashtable(F_FIXNUM capacity) +{ + F_HASHTABLE* hash; + if(capacity < 0) + general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_fixnum(capacity)); + hash = allot_object(HASHTABLE_TYPE,sizeof(F_VECTOR)); + hash->count = tag_fixnum(0); + hash->array = tag_object(array(capacity,F)); + return hash; +} + +void primitive_hashtable(void) +{ + maybe_garbage_collection(); + drepl(tag_object(hashtable(to_fixnum(dpeek())))); +} + +void primitive_to_hashtable(void) +{ + type_check(HASHTABLE_TYPE,dpeek()); +} + +void fixup_hashtable(F_HASHTABLE* hashtable) +{ + data_fixup(&hashtable->array); +} + +void collect_hashtable(F_HASHTABLE* hashtable) +{ + copy_object(&hashtable->array); +} diff --git a/native/hashtable.h b/native/hashtable.h new file mode 100644 index 0000000000..e464b2c198 --- /dev/null +++ b/native/hashtable.h @@ -0,0 +1,15 @@ +typedef struct { + /* always tag_header(HASHTABLE_TYPE) */ + CELL header; + /* tagged */ + CELL count; + /* tagged */ + CELL array; +} F_HASHTABLE; + +F_HASHTABLE* hashtable(F_FIXNUM capacity); + +void primitive_hashtable(void); +void primitive_to_hashtable(void); +void fixup_hashtable(F_HASHTABLE* hashtable); +void collect_hashtable(F_HASHTABLE* hashtable); diff --git a/native/primitives.c b/native/primitives.c index 07dd50f034..bf0723d7a9 100644 --- a/native/primitives.c +++ b/native/primitives.c @@ -168,11 +168,14 @@ void* primitives[] = { primitive_to_vector, primitive_to_string, primitive_to_word, + primitive_to_hashtable, primitive_slot, primitive_set_slot, primitive_integer_slot, primitive_set_integer_slot, - primitive_grow_array + primitive_grow_array, + primitive_hashtable, + primitive_array }; CELL primitive_to_xt(CELL primitive) diff --git a/native/relocate.c b/native/relocate.c index 6205243128..c6dfd0e73b 100644 --- a/native/relocate.c +++ b/native/relocate.c @@ -10,6 +10,9 @@ void relocate_object(CELL relocating) case ARRAY_TYPE: fixup_array((F_ARRAY*)relocating); break; + case HASHTABLE_TYPE: + fixup_hashtable((F_HASHTABLE*)relocating); + break; case VECTOR_TYPE: fixup_vector((F_VECTOR*)relocating); break; diff --git a/native/s48_bignumint.h b/native/s48_bignumint.h index 3150b1bf7a..5ce1f95059 100644 --- a/native/s48_bignumint.h +++ b/native/s48_bignumint.h @@ -83,7 +83,7 @@ typedef long bignum_length_type; #define BIGNUM_START_PTR(bignum) \ ((BIGNUM_TO_POINTER (bignum)) + 1) -#define BIGNUM_LENGTH(bignum) ((bignum)->capacity - 1) +#define BIGNUM_LENGTH(bignum) (untag_fixnum_fast((bignum)->capacity) - 1) #define BIGNUM_NEGATIVE_P(bignum) (get(AREF(bignum,0)) != 0) #define BIGNUM_SET_NEGATIVE_P(bignum,neg) put(AREF(bignum,0),neg) diff --git a/native/stack.c b/native/stack.c index 8e89917dd1..66d32c0678 100644 --- a/native/stack.c +++ b/native/stack.c @@ -81,7 +81,7 @@ F_VECTOR* stack_to_vector(CELL bottom, CELL top) F_VECTOR* v = vector(depth); F_ARRAY* a = untag_array(v->array); memcpy(a + 1,(void*)bottom,depth * CELLS); - v->top = depth; + v->top = tag_fixnum(depth); return v; } @@ -101,7 +101,7 @@ void primitive_callstack(void) CELL vector_to_stack(F_VECTOR* vector, CELL bottom) { CELL start = bottom; - CELL len = vector->top * CELLS; + CELL len = untag_fixnum_fast(vector->top) * CELLS; memcpy((void*)start,untag_array(vector->array) + 1,len); return start + len - CELLS; } diff --git a/native/types.c b/native/types.c index cc81333e63..a4048d22ed 100644 --- a/native/types.c +++ b/native/types.c @@ -55,6 +55,9 @@ CELL untagged_object_size(CELL pointer) case BIGNUM_TYPE: size = ASIZE(pointer); break; + case HASHTABLE_TYPE: + size = sizeof(F_HASHTABLE); + break; case VECTOR_TYPE: size = sizeof(F_VECTOR); break; diff --git a/native/types.h b/native/types.h index 8dddd21652..ac481e47da 100644 --- a/native/types.h +++ b/native/types.h @@ -27,6 +27,7 @@ CELL T; #define F_TYPE 9 #define F RETAG(0,OBJECT_TYPE) +#define HASHTABLE_TYPE 10 #define VECTOR_TYPE 11 #define STRING_TYPE 12 #define SBUF_TYPE 13 diff --git a/native/vector.c b/native/vector.c index 2b2e4a6866..010c1f6b58 100644 --- a/native/vector.c +++ b/native/vector.c @@ -6,7 +6,7 @@ F_VECTOR* vector(F_FIXNUM capacity) if(capacity < 0) general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_fixnum(capacity)); vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR)); - vector->top = 0; + vector->top = tag_fixnum(0); vector->array = tag_object(array(capacity,F)); return vector; } diff --git a/native/vector.h b/native/vector.h index cffc5a7ff4..8f0eb5a9ba 100644 --- a/native/vector.h +++ b/native/vector.h @@ -1,7 +1,7 @@ typedef struct { /* always tag_header(VECTOR_TYPE) */ CELL header; - /* untagged */ + /* tagged */ CELL top; /* tagged */ CELL array; From d29cd15f74f29b3845ce12ccc111713413069c12 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Jan 2005 04:55:22 +0000 Subject: [PATCH 037/122] growable hashtables --- library/arrays.factor | 5 +- library/bootstrap/boot-stage2.factor | 2 +- library/bootstrap/boot.factor | 2 +- library/bootstrap/image.factor | 20 ++--- library/cons.factor | 11 ++- library/hashtables.factor | 99 ++++++++++++++------ library/inference/branches.factor | 6 +- library/kernel.factor | 5 +- library/test/crashes.factor | 4 +- library/test/hashtables.factor | 18 +++- library/test/httpd/httpd.factor | 2 +- library/test/inference.factor | 1 - library/test/lists/namespaces.factor | 6 +- library/test/math/complex.factor | 68 +++++++------- library/test/parse-number.factor | 130 +++++++++++---------------- library/test/test.factor | 8 -- library/test/unparser.factor | 15 ++-- library/test/vectors.factor | 20 +++-- library/test/words.factor | 9 +- library/tools/interpreter.factor | 12 +-- library/vectors.factor | 17 ++-- library/vocabularies.factor | 6 +- library/words.factor | 12 ++- 23 files changed, 250 insertions(+), 228 deletions(-) diff --git a/library/arrays.factor b/library/arrays.factor index 0e052d9b7c..2d12372dd7 100644 --- a/library/arrays.factor +++ b/library/arrays.factor @@ -30,6 +30,7 @@ USE: generic USE: math-internals USE: kernel USE: lists +USE: vectors ! An array is a range of memory storing pointers to other ! objects. Arrays are not used directly, and their access words @@ -44,8 +45,8 @@ USE: lists BUILTIN: array 8 : array-capacity ( array -- n ) 1 slot ; inline -: vector-array ( vec -- array ) 2 slot ; inline -: set-vector-array ( array vec -- ) 2 set-slot ; inline +: vector-array ( vec -- array ) >vector 2 slot ; inline +: set-vector-array ( array vec -- ) >vector 2 set-slot ; inline : array-nth ( n array -- obj ) swap 2 fixnum+ slot ; inline diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index fdd77c2046..d7cc3a86e3 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -57,11 +57,11 @@ USE: namespaces "/library/math/ratio.factor" "/library/math/float.factor" "/library/math/complex.factor" - "/library/words.factor" "/library/lists.factor" "/library/vectors.factor" "/library/strings.factor" "/library/hashtables.factor" + "/library/words.factor" "/library/namespaces.factor" "/library/sbuf.factor" "/library/errors.factor" diff --git a/library/bootstrap/boot.factor b/library/bootstrap/boot.factor index d991caa709..981d27daa9 100644 --- a/library/bootstrap/boot.factor +++ b/library/bootstrap/boot.factor @@ -51,11 +51,11 @@ USE: hashtables "/library/math/ratio.factor" parse-resource append, "/library/math/float.factor" parse-resource append, "/library/math/complex.factor" parse-resource append, - "/library/words.factor" parse-resource append, "/library/lists.factor" parse-resource append, "/library/vectors.factor" parse-resource append, "/library/strings.factor" parse-resource append, "/library/hashtables.factor" parse-resource append, + "/library/words.factor" parse-resource append, "/library/namespaces.factor" parse-resource append, "/library/sbuf.factor" parse-resource append, "/library/errors.factor" parse-resource append, diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index 3115837abc..2594c13fc9 100644 --- a/library/bootstrap/image.factor +++ b/library/bootstrap/image.factor @@ -192,7 +192,7 @@ M: f ' ( obj -- ptr ) 0 , dup word-primitive , dup word-parameter ' , - dup word-plist ' , + dup word-props ' , 0 , 0 , ] make-list @@ -284,16 +284,16 @@ M: string ' ( string -- pointer ) M: vector ' ( vector -- pointer ) emit-vector ; -: rehash ( hashtable -- ) - ! Now make a rehashing boot quotation - dup hash>alist [ - over hash-clear - [ unswons rot set-hash ] each-with - ] cons cons - boot-quot [ append ] change ; +! : rehash ( hashtable -- ) +! ! Now make a rehashing boot quotation +! dup hash>alist [ +! over hash-clear +! [ unswons rot set-hash ] each-with +! ] cons cons +! boot-quot [ append ] change ; : emit-hashtable ( hash -- pointer ) - dup buckets>list emit-array swap hash-size + dup buckets>list emit-array swap hash>alist length object-tag here-as >r hashtable-type >header emit emit-fixnum ( length ) @@ -303,7 +303,7 @@ M: vector ' ( vector -- pointer ) M: hashtable ' ( hashtable -- pointer ) #! Only hashtables are pooled, not vectors! dup pooled-object [ - [ dup emit-hashtable [ pool-object ] keep ] keep rehash + dup emit-hashtable [ pool-object ] keep ] ?unless ; ( End of the image ) diff --git a/library/cons.factor b/library/cons.factor index d3af62c203..b8ec600864 100644 --- a/library/cons.factor +++ b/library/cons.factor @@ -80,6 +80,10 @@ PREDICATE: general-list list ( list -- ? ) #! cell whose cdr is a proper list. dup [ last* cdr ] when not ; +: with ( obj quot elt -- obj quot ) + #! Utility word for each-with, map-with. + pick pick >r >r swap call r> r> ; inline + : all? ( list pred -- ? ) #! Push if the predicate returns true for each element of #! the list. @@ -93,6 +97,9 @@ PREDICATE: general-list list ( list -- ? ) 2drop t ] ifte ; inline +: all-with? ( obj list pred -- ? ) + swap [ with rot ] all? 2nip ; inline + : (each) ( list quot -- list quot ) >r uncons r> tuck 2slip ; inline @@ -101,10 +108,6 @@ PREDICATE: general-list list ( list -- ? ) #! quotation with effect ( elt -- ) to each element. over [ (each) each ] [ 2drop ] ifte ; inline -: with ( obj quot elt -- obj quot ) - #! Utility word for each-with, map-with. - pick pick >r >r swap call r> r> ; inline - : each-with ( obj list quot -- ) #! Push each element of a proper list in turn, and apply a #! quotation with effect ( obj elt -- ) to each element. diff --git a/library/hashtables.factor b/library/hashtables.factor index 1bcc3fe9d1..73a31e081a 100644 --- a/library/hashtables.factor +++ b/library/hashtables.factor @@ -39,9 +39,14 @@ BUILTIN: hashtable 10 ! buckets are associative lists which are searched ! linearly. +! The unsafe words go in kernel internals. Everything else, even +! if it is somewhat 'implementation detail', is in the +! public 'hashtables' vocabulary. + IN: kernel-internals : hash-array 2 slot ; inline +: set-hash-array 2 set-slot ; inline : hash-bucket ( n hash -- alist ) swap >fixnum swap >hashtable hash-array array-nth ; inline @@ -50,14 +55,19 @@ IN: kernel-internals swap >fixnum swap >hashtable hash-array set-array-nth ; inline +: change-bucket ( n hash quot -- ) + -rot hash-array + [ array-nth swap call ] 2keep + set-array-nth ; inline + +IN: hashtables + : hash-size+ ( hash -- ) >hashtable dup 1 slot 1 + swap 1 set-slot ; inline : hash-size- ( hash -- ) >hashtable dup 1 slot 1 - swap 1 set-slot ; inline -IN: hashtables - : hash-size ( hash -- n ) #! Number of elements in the hashtable. >hashtable 1 slot ; @@ -80,24 +90,53 @@ IN: hashtables #! undefined value, or a value set to f. hash* dup [ cdr ] when ; -: set-hash* ( key table quot -- ) +: set-hash* ( key hash quot -- ) #! Apply the quotation to yield a new association list. #! If the association list already contains the key, #! decrement the hash size, since it will get removed. - >r - 2dup (hashcode) - r> pick >r - over >r - >r swap hash-bucket r> call - r> - r> set-hash-bucket ; inline - + -rot 2dup (hashcode) over [ + ( quot key hash assoc -- ) + swapd 2dup + assoc [ rot hash-size- ] [ rot drop ] ifte + rot call + ] change-bucket ; inline + +: rehash? ( hash -- ? ) + dup bucket-count 3 * 2 /i swap hash-size < ; + +: grow-hash ( hash -- ) + #! A good way to earn a living. + dup hash-size 3 * 2 /i swap set-hash-array ; + +: (hash>alist) ( alist n hash -- alist ) + 2dup bucket-count >= [ + 2drop + ] [ + [ hash-bucket [ swons ] each ] 2keep + >r 1 + r> (hash>alist) + ] ifte ; + +: hash>alist ( hash -- alist ) + #! Push a list of key/value pairs in a hashtable. + [ ] 0 rot (hash>alist) ; + +: (set-hash) ( value key hash -- ) + dup hash-size+ [ set-assoc ] set-hash* ; + +: rehash ( hash -- ) + #! Increase the hashtable size if its too small. + dup rehash? [ + dup hash>alist over grow-hash + [ unswons rot (set-hash) ] each-with + ] [ + drop + ] ifte ; + : set-hash ( value key table -- ) #! Store the value in the hashtable. Either replaces an #! existing value in the appropriate bucket, or adds a new #! key/value pair. - dup hash-size+ - [ set-assoc ] set-hash* ; + dup rehash (set-hash) ; : remove-hash ( key table -- ) #! Remove a value from a hashtable. @@ -113,20 +152,9 @@ IN: hashtables #! Push a list of key/value pairs in a hashtable. dup bucket-count swap hash-array array>list ; -: (hash>alist) ( alist n hash -- alist ) - 2dup bucket-count >= [ - 2drop - ] [ - [ hash-bucket [ swons ] each ] 2keep - >r 1 + r> (hash>alist) - ] ifte ; - -: hash>alist ( hash -- alist ) - #! Push a list of key/value pairs in a hashtable. - [ ] 0 rot (hash>alist) ; - : alist>hash ( alist -- hash ) - dup length swap [ unswons pick set-hash ] each ; + dup length 1 max swap + [ unswons pick set-hash ] each ; : hash-keys ( hash -- list ) #! Push a list of keys in a hashtable. @@ -139,3 +167,22 @@ IN: hashtables : hash-each ( hash code -- ) #! Apply the code to each key/value pair of the hashtable. >r hash>alist r> each ; inline + +M: hashtable clone ( hash -- hash ) + dup bucket-count dup [ + hash-array rot hash-array rot copy-array + ] keep ; + +: hash-subset? ( subset of -- ? ) + hash>alist [ uncons >r swap hash r> = ] all-with? ; + +M: hashtable = ( obj hash -- ? ) + 2dup eq? [ + 2drop t + ] [ + over hashtable? [ + 2dup hash-subset? >r swap hash-subset? r> and + ] [ + 2drop f + ] ifte + ] ifte ; diff --git a/library/inference/branches.factor b/library/inference/branches.factor index d78fe2a164..c5cff70a5f 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -108,11 +108,11 @@ USE: prettyprint SYMBOL: cloned -: deep-clone ( vector -- vector ) - #! Clone a vector if it hasn't already been cloned in this +: deep-clone ( obj -- obj ) + #! Clone an object if it hasn't already been cloned in this #! with-deep-clone scope. dup cloned get assoc [ - vector-clone [ dup cloned [ acons ] change ] keep + clone [ dup cloned [ acons ] change ] keep ] ?unless ; : deep-clone-vector ( vector -- vector ) diff --git a/library/kernel.factor b/library/kernel.factor index fb3c4544af..2bc2bd6f0a 100644 --- a/library/kernel.factor +++ b/library/kernel.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2004 Slava Pestov. +! Copyright (C) 2004, 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -43,6 +43,9 @@ M: object hashcode drop 0 ; GENERIC: = ( obj obj -- ? ) M: object = eq? ; +GENERIC: clone ( obj -- obj ) +M: object clone ; + : cpu ( -- arch ) #! Returns one of "x86" or "unknown". 7 getenv ; diff --git a/library/test/crashes.factor b/library/test/crashes.factor index 2a1bcb3fe4..eadb5b4f3d 100644 --- a/library/test/crashes.factor +++ b/library/test/crashes.factor @@ -25,7 +25,7 @@ USE: prettyprint 10 "x" set [ -2 "x" get set-vector-length ] [ drop ] catch -[ "x" get vector-clone drop ] [ drop ] catch +[ "x" get clone drop ] [ drop ] catch 10 [ [ -1000000 ] [ drop ] catch ] times @@ -57,7 +57,7 @@ USE: prettyprint : callstack-overflow callstack-overflow f ; [ callstack-overflow ] unit-test-fails -[ [ cdr cons ] word-plist ] unit-test-fails +[ [ cdr cons ] word-props ] unit-test-fails ! Forgot to tag out of bounds index [ 1 { } vector-nth ] [ garbage-collection drop ] catch diff --git a/library/test/hashtables.factor b/library/test/hashtables.factor index 37e74d53d7..bffd04b84c 100644 --- a/library/test/hashtables.factor +++ b/library/test/hashtables.factor @@ -45,7 +45,7 @@ f 100000000000000000000000000 "testhash" get set-hash [ t ] [ #{ 2 3 }# "testhash" get hash ] unit-test [ f ] [ 100000000000000000000000000 "testhash" get hash* cdr ] unit-test -[ { } ] [ { [ { } ] } vector-clone "testhash" get hash* cdr ] unit-test +[ { } ] [ { [ { } ] } clone "testhash" get hash* cdr ] unit-test [ [[ "salmon" "fish" ]] @@ -68,7 +68,19 @@ f 100000000000000000000000000 "testhash" get set-hash ! Testing the hash element counting "counting" set -"key" "value" "counting" get set-hash +"value" "key" "counting" get set-hash [ 1 ] [ "counting" get hash-size ] unit-test -"key" "value" "counting" get set-hash +"value" "key" "counting" get set-hash [ 1 ] [ "counting" get hash-size ] unit-test +"key" "counting" get remove-hash +[ 0 ] [ "counting" get hash-size ] unit-test +"key" "counting" get remove-hash +[ 0 ] [ "counting" get hash-size ] unit-test + +[ t ] [ {{ }} dup = ] unit-test +[ f ] [ "xyz" {{ }} = ] unit-test +[ t ] [ {{ }} {{ }} = ] unit-test +[ f ] [ {{ [[ 1 3 ]] }} {{ }} = ] unit-test +[ f ] [ {{ }} {{ [[ 1 3 ]] }} = ] unit-test +[ t ] [ {{ [[ 1 3 ]] }} {{ [[ 1 3 ]] }} = ] unit-test +[ f ] [ {{ [[ 1 3 ]] }} {{ [[ 1 "hey" ]] }} = ] unit-test diff --git a/library/test/httpd/httpd.factor b/library/test/httpd/httpd.factor index 94409070fe..9d604042ba 100644 --- a/library/test/httpd/httpd.factor +++ b/library/test/httpd/httpd.factor @@ -29,7 +29,7 @@ USE: lists "X-Spyware-Requested: yes" header-line ] unit-test -[ ] [ "404 not found" ] [ httpd-error ] test-word +[ ] [ "404 not found" httpd-error ] unit-test [ "arg" ] [ [ diff --git a/library/test/inference.factor b/library/test/inference.factor index eb06775ab9..bb53417af0 100644 --- a/library/test/inference.factor +++ b/library/test/inference.factor @@ -218,7 +218,6 @@ SYMBOL: sym-test [ [ [ object object ] [ cons ] ] ] [ [ cons ] infer ] unit-test [ [ [ cons ] [ cons ] ] ] [ [ uncons cons ] infer ] unit-test [ [ [ general-list ] [ object ] ] ] [ [ dup [ car ] when ] infer ] unit-test -[ [ [ vector ] [ vector ] ] ] [ [ vector-clone ] infer ] unit-test ! [ [ [ number ] [ number ] ] ] [ [ dup + ] infer ] unit-test ! [ [ [ number number number ] [ number ] ] ] [ [ digit+ ] infer ] unit-test [ [ [ number ] [ real real ] ] ] [ [ >rect ] infer ] unit-test diff --git a/library/test/lists/namespaces.factor b/library/test/lists/namespaces.factor index 190e781399..2f26ad1bd6 100644 --- a/library/test/lists/namespaces.factor +++ b/library/test/lists/namespaces.factor @@ -3,9 +3,9 @@ USE: lists USE: namespaces USE: test -[ [ 1 ] ] [ 1 f ] [ "x" set "x" cons@ "x" get ] test-word -[ [[ 1 2 ]] ] [ 1 2 ] [ "x" set "x" cons@ "x" get ] test-word -[ [ 1 2 ] ] [ 1 [ 2 ] ] [ "x" set "x" cons@ "x" get ] test-word +[ [ 1 ] ] [ 1 f "x" set "x" cons@ "x" get ] unit-test +[ [[ 1 2 ]] ] [ 1 2 "x" set "x" cons@ "x" get ] unit-test +[ [ 1 2 ] ] [ 1 [ 2 ] "x" set "x" cons@ "x" get ] unit-test [ [ [[ 2 3 ]] [[ 1 2 ]] ] ] [ "x" off 2 1 "x" [ acons ] change 3 2 "x" [ acons ] change "x" get diff --git a/library/test/math/complex.factor b/library/test/math/complex.factor index 1c509a5b43..4f41d25ae1 100644 --- a/library/test/math/complex.factor +++ b/library/test/math/complex.factor @@ -6,45 +6,45 @@ USE: test [ 1 #{ 0 1 }# rect> ] unit-test-fails [ #{ 0 1 }# 1 rect> ] unit-test-fails -[ f ] [ #{ 5 12.5 }# 5 ] [ = ] test-word -[ t ] [ #{ 1.0 2.0 }# #{ 1 2 }# ] [ = ] test-word -[ f ] [ #{ 1.0 2.3 }# #{ 1 2 }# ] [ = ] test-word +[ f ] [ #{ 5 12.5 }# 5 = ] unit-test +[ t ] [ #{ 1.0 2.0 }# #{ 1 2 }# = ] unit-test +[ f ] [ #{ 1.0 2.3 }# #{ 1 2 }# = ] unit-test -[ #{ 2 5 }# ] [ 2 5 ] [ rect> ] test-word -[ 2 5 ] [ #{ 2 5 }# ] [ >rect ] test-word -[ #{ 1/2 1 }# ] [ 1/2 i ] [ + ] test-word -[ #{ 1/2 1 }# ] [ i 1/2 ] [ + ] test-word -[ t ] [ #{ 11 64 }# #{ 11 64 }# ] [ = ] test-word -[ #{ 2 1 }# ] [ 2 i ] [ + ] test-word -[ #{ 2 1 }# ] [ i 2 ] [ + ] test-word -[ #{ 5 4 }# ] [ #{ 2 2 }# #{ 3 2 }# ] [ + ] test-word -[ 5 ] [ #{ 2 2 }# #{ 3 -2 }# ] [ + ] test-word -[ #{ 1.0 1 }# ] [ 1.0 i ] [ + ] test-word +[ #{ 2 5 }# ] [ 2 5 rect> ] unit-test +[ 2 5 ] [ #{ 2 5 }# >rect ] unit-test +[ #{ 1/2 1 }# ] [ 1/2 i + ] unit-test +[ #{ 1/2 1 }# ] [ i 1/2 + ] unit-test +[ t ] [ #{ 11 64 }# #{ 11 64 }# = ] unit-test +[ #{ 2 1 }# ] [ 2 i + ] unit-test +[ #{ 2 1 }# ] [ i 2 + ] unit-test +[ #{ 5 4 }# ] [ #{ 2 2 }# #{ 3 2 }# + ] unit-test +[ 5 ] [ #{ 2 2 }# #{ 3 -2 }# + ] unit-test +[ #{ 1.0 1 }# ] [ 1.0 i + ] unit-test -[ #{ 1/2 -1 }# ] [ 1/2 i ] [ - ] test-word -[ #{ -1/2 1 }# ] [ i 1/2 ] [ - ] test-word -[ #{ 1/3 1/4 }# ] [ 1 3 / 1 2 / i * + 1 4 / i * ] [ - ] test-word -[ #{ -1/3 -1/4 }# ] [ 1 4 / i * 1 3 / 1 2 / i * + ] [ - ] test-word -[ #{ 1/5 1/4 }# ] [ #{ 3/5 1/2 }# #{ 2/5 1/4 }# ] [ - ] test-word -[ 4 ] [ #{ 5 10/3 }# #{ 1 10/3 }# ] [ - ] test-word -[ #{ 1.0 -1 }# ] [ 1.0 i ] [ - ] test-word +[ #{ 1/2 -1 }# ] [ 1/2 i - ] unit-test +[ #{ -1/2 1 }# ] [ i 1/2 - ] unit-test +[ #{ 1/3 1/4 }# ] [ 1 3 / 1 2 / i * + 1 4 / i * - ] unit-test +[ #{ -1/3 -1/4 }# ] [ 1 4 / i * 1 3 / 1 2 / i * + - ] unit-test +[ #{ 1/5 1/4 }# ] [ #{ 3/5 1/2 }# #{ 2/5 1/4 }# - ] unit-test +[ 4 ] [ #{ 5 10/3 }# #{ 1 10/3 }# - ] unit-test +[ #{ 1.0 -1 }# ] [ 1.0 i - ] unit-test -[ #{ 0 1 }# ] [ i 1 ] [ * ] test-word -[ #{ 0 1 }# ] [ 1 i ] [ * ] test-word -[ #{ 0 1.0 }# ] [ 1.0 i ] [ * ] test-word -[ -1 ] [ i i ] [ * ] test-word -[ #{ 0 1 }# ] [ 1 i ] [ * ] test-word -[ #{ 0 1 }# ] [ i 1 ] [ * ] test-word -[ #{ 0 1/2 }# ] [ 1/2 i ] [ * ] test-word -[ #{ 0 1/2 }# ] [ i 1/2 ] [ * ] test-word -[ 2 ] [ #{ 1 1 }# #{ 1 -1 }# ] [ * ] test-word -[ 1 ] [ i -i ] [ * ] test-word +[ #{ 0 1 }# ] [ i 1 * ] unit-test +[ #{ 0 1 }# ] [ 1 i * ] unit-test +[ #{ 0 1.0 }# ] [ 1.0 i * ] unit-test +[ -1 ] [ i i * ] unit-test +[ #{ 0 1 }# ] [ 1 i * ] unit-test +[ #{ 0 1 }# ] [ i 1 * ] unit-test +[ #{ 0 1/2 }# ] [ 1/2 i * ] unit-test +[ #{ 0 1/2 }# ] [ i 1/2 * ] unit-test +[ 2 ] [ #{ 1 1 }# #{ 1 -1 }# * ] unit-test +[ 1 ] [ i -i * ] unit-test -[ -1 ] [ i -i ] [ / ] test-word -[ #{ 0 1 }# ] [ 1 -i ] [ / ] test-word -[ t ] [ #{ 12 13 }# #{ 13 14 }# / #{ 13 14 }# * #{ 12 13 }# ] [ = ] test-word +[ -1 ] [ i -i / ] unit-test +[ #{ 0 1 }# ] [ 1 -i / ] unit-test +[ t ] [ #{ 12 13 }# #{ 13 14 }# / #{ 13 14 }# * #{ 12 13 }# = ] unit-test -[ #{ -3 4 }# ] [ #{ 3 -4 }# ] [ neg ] test-word +[ #{ -3 4 }# ] [ #{ 3 -4 }# neg ] unit-test [ 5 ] [ #{ 3 4 }# abs ] unit-test [ 5 ] [ -5.0 abs ] unit-test diff --git a/library/test/parse-number.factor b/library/test/parse-number.factor index 42555574c0..26a334f9ff 100644 --- a/library/test/parse-number.factor +++ b/library/test/parse-number.factor @@ -6,134 +6,108 @@ USE: test USE: unparser [ f ] -[ f ] -[ parse-number ] -test-word +[ f parse-number ] +unit-test [ f ] -[ "12345abcdef" ] -[ parse-number ] -test-word +[ "12345abcdef" parse-number ] +unit-test [ t ] -[ "-12" ] -[ parse-number 0 < ] -test-word +[ "-12" parse-number 0 < ] +unit-test [ f ] -[ "--12" ] -[ parse-number ] -test-word +[ "--12" parse-number ] +unit-test [ f ] -[ "-" ] -[ parse-number ] -test-word +[ "-" parse-number ] +unit-test [ f ] -[ "e" ] -[ parse-number ] -test-word +[ "e" parse-number ] +unit-test [ "100.0" ] -[ "1.0e2" ] -[ parse-number unparse ] -test-word +[ "1.0e2" parse-number unparse ] +unit-test [ "-100.0" ] -[ "-1.0e2" ] -[ parse-number unparse ] -test-word +[ "-1.0e2" parse-number unparse ] +unit-test [ "0.01" ] -[ "1.0e-2" ] -[ parse-number unparse ] -test-word +[ "1.0e-2" parse-number unparse ] +unit-test [ "-0.01" ] -[ "-1.0e-2" ] -[ parse-number unparse ] -test-word +[ "-1.0e-2" parse-number unparse ] +unit-test [ f ] -[ "-1e-2e4" ] -[ parse-number ] -test-word +[ "-1e-2e4" parse-number ] +unit-test [ "3.14" ] -[ "3.14" ] -[ parse-number unparse ] -test-word +[ "3.14" parse-number unparse ] +unit-test [ f ] -[ "." ] -[ parse-number ] -test-word +[ "." parse-number ] +unit-test [ f ] -[ ".e" ] -[ parse-number ] -test-word +[ ".e" parse-number ] +unit-test [ "101.0" ] -[ "1.01e2" ] -[ parse-number unparse ] -test-word +[ "1.01e2" parse-number unparse ] +unit-test [ "-101.0" ] -[ "-1.01e2" ] -[ parse-number unparse ] -test-word +[ "-1.01e2" parse-number unparse ] +unit-test [ "1.01" ] -[ "101.0e-2" ] -[ parse-number unparse ] -test-word +[ "101.0e-2" parse-number unparse ] +unit-test [ "-1.01" ] -[ "-101.0e-2" ] -[ parse-number unparse ] -test-word +[ "-101.0e-2" parse-number unparse ] +unit-test [ 5 ] -[ "10/2" ] -[ parse-number ] -test-word +[ "10/2" parse-number ] +unit-test [ -5 ] -[ "-10/2" ] -[ parse-number ] -test-word +[ "-10/2" parse-number ] +unit-test [ -5 ] -[ "10/-2" ] -[ parse-number ] -test-word +[ "10/-2" parse-number ] +unit-test [ 5 ] -[ "-10/-2" ] -[ parse-number ] -test-word +[ "-10/-2" parse-number ] +unit-test [ f ] -[ "10.0/2" ] -[ parse-number ] -test-word +[ "10.0/2" parse-number ] +unit-test [ f ] -[ "1e1/2" ] -[ parse-number ] -test-word +[ "1e1/2" parse-number ] +unit-test [ f ] -[ "e/2" ] -[ parse-number ] -test-word +[ "e/2" parse-number ] +unit-test [ "33/100" ] -[ "66/200" ] -[ parse-number unparse ] -test-word +[ "66/200" parse-number unparse ] +unit-test [ "12" bin> ] unit-test-fails [ "fdsf" bin> ] unit-test-fails diff --git a/library/test/test.factor b/library/test/test.factor index 2a8fe1063f..e412cf6d91 100644 --- a/library/test/test.factor +++ b/library/test/test.factor @@ -43,14 +43,6 @@ USE: unparser #! Assert that the quotation throws an error. [ [ not ] catch ] cons [ f ] swap unit-test ; -: test-word ( output input word -- ) - #! Old-style test. - append unit-test ; - -: do-not-test-word ( output input word -- ) - #! Flag for tests that are known not to work. - 3drop ; - : test ( name -- ) ! Run the given test. depth 1 - >r diff --git a/library/test/unparser.factor b/library/test/unparser.factor index 99c12fde8d..4756c09b51 100644 --- a/library/test/unparser.factor +++ b/library/test/unparser.factor @@ -8,19 +8,16 @@ USE: kernel USE: io-internals [ "\"hello\\\\backslash\"" ] -[ "hello\\backslash" ] -[ unparse ] -test-word +[ "hello\\backslash" unparse ] +unit-test [ "\"\\u1234\"" ] -[ "\u1234" ] -[ unparse ] -test-word +[ "\u1234" unparse ] +unit-test [ "\"\\e\"" ] -[ "\e" ] -[ unparse ] -test-word +[ "\e" unparse ] +unit-test [ "1.0" ] [ 1.0 unparse ] unit-test [ "f" ] [ f unparse ] unit-test diff --git a/library/test/vectors.factor b/library/test/vectors.factor index d55b1fe168..9726a57c50 100644 --- a/library/test/vectors.factor +++ b/library/test/vectors.factor @@ -37,14 +37,11 @@ USE: kernel-internals [ f ] [ [ 1 2 ] { 1 2 3 } = ] unit-test [ f ] [ { 1 2 } [ 1 2 3 ] = ] unit-test -[ [ 1 4 9 16 ] ] [ [ 1 2 3 4 ] ] -[ list>vector [ dup * ] vector-map vector>list ] test-word -[ t ] [ [ 1 2 3 4 ] ] -[ list>vector [ number? ] vector-all? ] test-word -[ f ] [ [ 1 2 3 4 ] ] -[ list>vector [ 3 > ] vector-all? ] test-word -[ t ] [ [ ] ] -[ list>vector [ 3 > ] vector-all? ] test-word +[ [ 1 4 9 16 ] ] +[ + [ 1 2 3 4 ] + list>vector [ dup * ] vector-map vector>list +] unit-test [ t ] [ { } hashcode { } hashcode = ] unit-test [ t ] [ { 1 2 3 } hashcode { 1 2 3 } hashcode = ] unit-test @@ -79,6 +76,11 @@ unit-test [ t ] [ { 1 2 3 4 } dup vector-array array-capacity - >r vector-clone vector-array array-capacity r> + >r clone vector-array array-capacity r> = ] unit-test + +[ f ] [ + { 1 2 3 4 } dup clone + swap vector-array swap vector-array eq? +] unit-test diff --git a/library/test/words.factor b/library/test/words.factor index e8198c12e1..c4fe3179f7 100644 --- a/library/test/words.factor +++ b/library/test/words.factor @@ -11,10 +11,7 @@ USE: kernel "poo" [ "scratchpad" ] search execute ] unit-test -: words-test ( -- ? ) - t vocabs [ words [ word? and ] each ] each ; - -[ t ] [ ] [ words-test ] test-word +[ t ] [ t vocabs [ words [ word? and ] each ] each ] unit-test DEFER: plist-test @@ -28,7 +25,7 @@ DEFER: plist-test \ plist-test "sample-property" word-property ] unit-test -[ f ] [ 5 ] [ compound? ] test-word +[ f ] [ 5 compound? ] unit-test "create-test" "scratchpad" create { 1 2 } "testing" set-word-property [ { 1 2 } ] [ @@ -62,4 +59,4 @@ SYMBOL: a-symbol : test-last ( -- ) ; word word-name "last-word-test" set -[ "test-last" ] [ ] [ "last-word-test" get ] test-word +[ "test-last" ] [ "last-word-test" get ] unit-test diff --git a/library/tools/interpreter.factor b/library/tools/interpreter.factor index c6a8297c10..7955f3050c 100644 --- a/library/tools/interpreter.factor +++ b/library/tools/interpreter.factor @@ -63,8 +63,8 @@ SYMBOL: meta-cf : copy-interpreter ( -- ) #! Copy interpreter state from containing namespaces. - meta-r [ vector-clone ] change - meta-d [ vector-clone ] change + meta-r [ clone ] change + meta-d [ clone ] change meta-n [ ] change meta-c [ ] change ; @@ -132,12 +132,12 @@ SYMBOL: meta-cf : set-meta-word ( word quot -- ) "meta-word" set-word-property ; -\ datastack [ meta-d get vector-clone push-d ] set-meta-word -\ set-datastack [ pop-d vector-clone meta-d set ] set-meta-word +\ datastack [ meta-d get clone push-d ] set-meta-word +\ set-datastack [ pop-d clone meta-d set ] set-meta-word \ >r [ pop-d push-r ] set-meta-word \ r> [ pop-r push-d ] set-meta-word -\ callstack [ meta-r get vector-clone push-d ] set-meta-word -\ set-callstack [ pop-d vector-clone meta-r set ] set-meta-word +\ callstack [ meta-r get clone push-d ] set-meta-word +\ set-callstack [ pop-d clone meta-r set ] set-meta-word \ namestack [ meta-n get push-d ] set-meta-word \ set-namestack [ pop-d meta-n set ] set-meta-word \ catchstack [ meta-c get push-d ] set-meta-word diff --git a/library/vectors.factor b/library/vectors.factor index 57124a65cd..6853420256 100644 --- a/library/vectors.factor +++ b/library/vectors.factor @@ -70,6 +70,9 @@ IN: kernel-internals 2drop ] ifte ; inline +: copy-array ( to from n -- ) + [ 3dup swap array-nth pick rot set-array-nth ] repeat 2drop ; + IN: vectors : vector-nth ( n vec -- obj ) @@ -123,13 +126,6 @@ IN: vectors swap >r apply r> tuck vector-push ] vector-each nip ; inline -: vector-and ( vector -- ? ) - #! Logical and of all elements in the vector. - t swap [ and ] vector-each ; - -: vector-all? ( vector pred -- ? ) - vector-map vector-and ; inline - : vector-nappend ( v1 v2 -- ) #! Destructively append v2 to v1. [ over vector-push ] vector-each drop ; @@ -148,9 +144,10 @@ IN: vectors #! in a new vector. project list>vector ; inline -: vector-clone ( vector -- vector ) - #! Shallow copy of a vector. - [ ] vector-map ; +M: vector clone ( vector -- vector ) + dup vector-length dup empty-vector [ + vector-array rot vector-array rot copy-array + ] keep ; : vector-length= ( vec vec -- ? ) vector-length swap vector-length number= ; diff --git a/library/vocabularies.factor b/library/vocabularies.factor index 9b4ad2c544..f1d1e3178f 100644 --- a/library/vocabularies.factor +++ b/library/vocabularies.factor @@ -68,12 +68,12 @@ USE: strings 2drop f ] ifte ; -: ( name vocab -- plist ) - "vocabulary" swons swap "name" swons 2list ; +: ( name vocab -- plist ) + "vocabulary" swons swap "name" swons 2list alist>hash ; : (create) ( name vocab -- word ) #! Create an undefined word without adding to a vocabulary. - [ set-word-plist ] keep ; + [ set-word-props ] keep ; : reveal ( word -- ) #! Add a new word to its vocabulary. diff --git a/library/words.factor b/library/words.factor index fcfbf800dd..e05aa95fca 100644 --- a/library/words.factor +++ b/library/words.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2003 Slava Pestov. +! Copyright (C) 2003, 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -49,8 +49,8 @@ M: word hashcode 1 slot %fixnum ; : word-parameter ( w -- obj ) >word 4 slot ; inline : set-word-parameter ( obj w -- ) >word 4 set-slot ; inline -: word-plist ( w -- obj ) >word 5 slot ; inline -: set-word-plist ( obj w -- ) >word 5 set-slot ; inline +: word-props ( w -- obj ) >word 5 slot ; inline +: set-word-props ( obj w -- ) >word 5 set-slot ; inline : call-count ( w -- n ) >word 6 integer-slot ; inline : set-call-count ( n w -- ) >word 6 set-integer-slot ; inline @@ -61,12 +61,10 @@ M: word hashcode 1 slot %fixnum ; SYMBOL: vocabularies : word-property ( word pname -- pvalue ) - swap word-plist assoc ; inline + swap word-props hash ; inline : set-word-property ( word pvalue pname -- ) - pick word-plist - pick [ set-assoc ] [ remove-assoc nip ] ifte - swap set-word-plist ; inline + rot word-props set-hash ; inline PREDICATE: word compound ( obj -- ? ) word-primitive 1 = ; PREDICATE: word primitive ( obj -- ? ) word-primitive 2 > ; From 12eceb5b44c5ae8618adc27fb8b5b3eb70bd34f8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Jan 2005 05:07:56 +0000 Subject: [PATCH 038/122] removed , , renamed to , to --- TODO.FACTOR.txt | 3 +-- library/bootstrap/image.factor | 5 ++--- library/hashtables.factor | 2 +- library/httpd/file-responder.factor | 2 +- library/httpd/httpd.factor | 2 +- library/io/logging.factor | 2 +- library/io/stream-impl.factor | 12 +++--------- library/syntax/parse-stream.factor | 4 ++-- library/tools/jedit.factor | 2 +- 9 files changed, 13 insertions(+), 21 deletions(-) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 3ec887c84f..9dca8e1508 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -47,13 +47,11 @@ - nicer way to combine two paths - add a socket timeout - rename f* words to stream-* -- is badly named -- , + kernel: - ppc register decls - cat, reverse-cat primitives -- first-class hashtables + misc: @@ -63,6 +61,7 @@ - browser responder for word links in HTTPd - worddef props - prettyprint: when unparse called due to recursion, write a link +- vectors: ensure its ok with bignum indices + httpd: diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index 2594c13fc9..b5337eb04f 100644 --- a/library/bootstrap/image.factor +++ b/library/bootstrap/image.factor @@ -352,16 +352,15 @@ M: hashtable ' ( hashtable -- pointer ) ] ifte ; : write-image ( image file -- ) - [ [ write-word ] vector-each ] with-stream ; + [ [ write-word ] vector-each ] with-stream ; : with-minimal-image ( quot -- image ) [ 300000 image set - 521 "objects" set + "objects" set ! Note that this is a vector that we can side-effect, ! since ; ends up using this variable from nested ! parser namespaces. - 1000 "word-fixups" set call image get ] with-scope ; diff --git a/library/hashtables.factor b/library/hashtables.factor index 73a31e081a..fb3162dd42 100644 --- a/library/hashtables.factor +++ b/library/hashtables.factor @@ -106,7 +106,7 @@ IN: hashtables : grow-hash ( hash -- ) #! A good way to earn a living. - dup hash-size 3 * 2 /i swap set-hash-array ; + dup hash-size 2 * swap set-hash-array ; : (hash>alist) ( alist n hash -- alist ) 2dup bucket-count >= [ diff --git a/library/httpd/file-responder.factor b/library/httpd/file-responder.factor index ea4d8c45b3..61231fd17f 100644 --- a/library/httpd/file-responder.factor +++ b/library/httpd/file-responder.factor @@ -54,7 +54,7 @@ USE: unparser over file-length file-response "method" get "head" = [ drop ] [ - stdio get fcopy + stdio get fcopy ] ifte ; : serve-file ( filename -- ) diff --git a/library/httpd/httpd.factor b/library/httpd/httpd.factor index a55fcdff08..2d597f79fe 100644 --- a/library/httpd/httpd.factor +++ b/library/httpd/httpd.factor @@ -41,7 +41,7 @@ USE: url-encoding : httpd-log-stream ( -- stream ) #! Set httpd-log-file to save httpd log to a file. "httpd-log-file" get dup [ - + ] [ drop stdio get ] ifte ; diff --git a/library/io/logging.factor b/library/io/logging.factor index 07b97e50c3..4627bc6a53 100644 --- a/library/io/logging.factor +++ b/library/io/logging.factor @@ -51,4 +51,4 @@ USE: unparser [ stdio get "log" set call ] with-scope ; : with-log-file ( file quot -- ) - [ swap "log" set call ] with-scope ; + [ swap "log" set call ] with-scope ; diff --git a/library/io/stream-impl.factor b/library/io/stream-impl.factor index bd756b11c6..a69eb54885 100644 --- a/library/io/stream-impl.factor +++ b/library/io/stream-impl.factor @@ -64,18 +64,12 @@ M: fd-stream fclose ( -- ) C: fd-stream ( in out -- stream ) [ "out" set "in" set ] extend ; -: ( path -- stream ) +: ( path -- stream ) t f open-file ; -: ( path -- stream ) +: ( path -- stream ) f t open-file ; -: ( path -- stream ) - ; - -: ( path -- stream ) - ; - : init-stdio ( -- ) stdin stdout stdio set ; @@ -94,4 +88,4 @@ C: fd-stream ( in out -- stream ) "resource-path" get [ "." ] unless* ; : ( path -- stream ) - resource-path swap cat2 ; + resource-path swap cat2 ; diff --git a/library/syntax/parse-stream.factor b/library/syntax/parse-stream.factor index 2c84fa87d9..6141184472 100644 --- a/library/syntax/parse-stream.factor +++ b/library/syntax/parse-stream.factor @@ -75,7 +75,7 @@ USE: strings [ file-vocabs (parse-stream) ] with-scope ; : parse-file ( file -- quot ) - dup parse-stream ; + dup parse-stream ; : run-file ( file -- ) #! Run a file. The file is read with the default IN:/USE: @@ -83,7 +83,7 @@ USE: strings parse-file call ; : (parse-file) ( file -- quot ) - dup (parse-stream) ; + dup (parse-stream) ; : (run-file) ( file -- ) #! Run a file. The file is read with the same IN:/USE: as diff --git a/library/tools/jedit.factor b/library/tools/jedit.factor index 39ee372a61..5d30a9105b 100644 --- a/library/tools/jedit.factor +++ b/library/tools/jedit.factor @@ -41,7 +41,7 @@ USE: words [ "~" get "/.jedit/server" cat2 ] unless* ; : jedit-server-info ( -- port auth ) - jedit-server-file [ + jedit-server-file [ read drop read parse-number read parse-number From 5b524a0fffa077b57489f1bda16403d14860b9a6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Jan 2005 19:18:28 +0000 Subject: [PATCH 039/122] USING: parsing word more compact than multiple USE: --- TODO.FACTOR.txt | 2 +- factor/DefaultVocabularyLookup.java | 4 +- factor/parser/Using.java | 55 +++++++++++++++++++++++ library/arrays.factor | 33 +------------- library/assoc.factor | 30 +------------ library/cli.factor | 44 ++---------------- library/combinators.factor | 29 +----------- library/cons.factor | 34 ++------------ library/continuations.factor | 36 ++------------- library/errors.factor | 42 ++--------------- library/eval-catch.factor | 34 ++------------ library/gensym.factor | 36 ++------------- library/hashtables.factor | 41 ++++------------- library/in-thread.factor | 35 ++------------- library/kernel.factor | 32 +------------ library/lists.factor | 32 +------------ library/namespaces.factor | 46 ++++--------------- library/primitives.factor | 51 +++------------------ library/random.factor | 48 +++----------------- library/sbuf.factor | 36 ++------------- library/stack.factor | 29 +----------- library/strings.factor | 36 ++------------- library/syntax/parse-syntax.factor | 6 +++ library/syntax/parser.factor | 9 +++- library/threads.factor | 33 +------------- library/vectors.factor | 36 ++------------- library/vocabularies.factor | 70 ++++------------------------- library/words.factor | 39 ++-------------- 28 files changed, 161 insertions(+), 797 deletions(-) create mode 100644 factor/parser/Using.java diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 9dca8e1508..705daa5a99 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -60,7 +60,7 @@ - jedit ==> jedit-word, jedit takes a file name - browser responder for word links in HTTPd - worddef props -- prettyprint: when unparse called due to recursion, write a link +- prettyprint: detect circular structure - vectors: ensure its ok with bignum indices + httpd: diff --git a/factor/DefaultVocabularyLookup.java b/factor/DefaultVocabularyLookup.java index 9c2ced02e9..fd18adb2e9 100644 --- a/factor/DefaultVocabularyLookup.java +++ b/factor/DefaultVocabularyLookup.java @@ -68,7 +68,7 @@ public class DefaultVocabularyLookup implements VocabularyLookup FactorWord f = define("syntax","f"); f.parsing = new F(f); FactorWord complex = define("syntax","#{"); - complex.parsing = new ComplexLiteral(complex,"}"); + complex.parsing = new ComplexLiteral(complex,"}#"); /* lists */ FactorWord bra = define("syntax","["); @@ -114,6 +114,8 @@ public class DefaultVocabularyLookup implements VocabularyLookup in.parsing = new In(in); FactorWord use = define("syntax","USE:"); use.parsing = new Use(use); + FactorWord using = define("syntax","USING:"); + using.parsing = new Using(using); FactorWord pushWord = define("syntax","\\"); pushWord.parsing = new PushWord(pushWord); diff --git a/factor/parser/Using.java b/factor/parser/Using.java new file mode 100644 index 0000000000..9f36bfc470 --- /dev/null +++ b/factor/parser/Using.java @@ -0,0 +1,55 @@ +/* :folding=explicit:collapseFolds=1: */ + +/* + * $Id$ + * + * Copyright (C) 2004 Slava Pestov. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * 1. Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND + * FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; + * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, + * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR + * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF + * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + */ + +package factor.parser; + +import factor.*; + +public class Using extends FactorParsingDefinition +{ + public Using(FactorWord word) + { + super(word); + } + + public void eval(FactorReader reader) + throws Exception + { + for(;;) + { + Object next = reader.next(false,false); + if(next == null) + reader.getScanner().error("Expected ;"); + if(next.equals(";")) + break; + else if(next instanceof String) + reader.addUse((String)next); + } + } +} diff --git a/library/arrays.factor b/library/arrays.factor index 2d12372dd7..5882102894 100644 --- a/library/arrays.factor +++ b/library/arrays.factor @@ -1,36 +1,7 @@ -! :folding=none:collapseFolds=1: - -! $Id$ -! ! Copyright (C) 2005 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! See http://factor.sf.net/license.txt for BSD license. IN: kernel-internals -USE: generic -USE: math-internals -USE: kernel -USE: lists -USE: vectors +USING: generic math-internals kernel lists vectors ; ! An array is a range of memory storing pointers to other ! objects. Arrays are not used directly, and their access words diff --git a/library/assoc.factor b/library/assoc.factor index e3da70d8da..713b8be1d7 100644 --- a/library/assoc.factor +++ b/library/assoc.factor @@ -1,32 +1,6 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! ! Copyright (C) 2004, 2005 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -IN: lists -USE: kernel +! See http://factor.sf.net/license.txt for BSD license. +IN: lists USING: kernel ; ! An association list is a list of conses where the car of each ! cons is a key, and the cdr is a value. See the Factor diff --git a/library/cli.factor b/library/cli.factor index afb242a945..d08db81414 100644 --- a/library/cli.factor +++ b/library/cli.factor @@ -1,46 +1,8 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! ! Copyright (C) 2003, 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! See http://factor.sf.net/license.txt for BSD license. IN: command-line -USE: compiler -USE: errors -USE: files -USE: listener -USE: kernel -USE: lists -USE: namespaces -USE: parser -USE: prettyprint -USE: random -USE: stdio -USE: streams -USE: strings -USE: words -USE: kernel-internals +USING: files kernel lists namespaces parser strings +kernel-internals ; ! This file is run as the last stage of boot.factor; it relies ! on all other words already being defined. diff --git a/library/combinators.factor b/library/combinators.factor index 6c0e912e8e..973fb95a66 100644 --- a/library/combinators.factor +++ b/library/combinators.factor @@ -1,30 +1,5 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2003, 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! Copyright (C) 2003, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: kernel : slip ( quot x -- x ) diff --git a/library/cons.factor b/library/cons.factor index b8ec600864..df8d0352fd 100644 --- a/library/cons.factor +++ b/library/cons.factor @@ -1,34 +1,6 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2003, 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -IN: lists -USE: generic -USE: kernel -USE: kernel-internals +! Copyright (C) 2003, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: lists USING: generic kernel kernel-internals ; ! This file contains vital list-related words that everything ! else depends on, and is loaded early in bootstrap. diff --git a/library/continuations.factor b/library/continuations.factor index 2174440544..263c5cd638 100644 --- a/library/continuations.factor +++ b/library/continuations.factor @@ -1,36 +1,6 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2003, 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -IN: kernel -USE: errors -USE: kernel -USE: lists -USE: namespaces -USE: vectors +! Copyright (C) 2003, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: kernel USING: errors lists namespaces vectors ; : reify ( quot -- ) >r datastack >pop> callstack >pop> namestack catchstack diff --git a/library/errors.factor b/library/errors.factor index 00def19460..46c81d2db0 100644 --- a/library/errors.factor +++ b/library/errors.factor @@ -1,41 +1,7 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -IN: kernel -DEFER: callcc1 - -IN: errors -USE: kernel -USE: kernel-internals -USE: lists -USE: math -USE: namespaces -USE: strings -USE: vectors +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: kernel DEFER: callcc1 +IN: errors USING: kernel-internals lists namespaces ; : undefined-method ( object generic -- ) #! This word is redefined in tools/debugger.factor with a diff --git a/library/eval-catch.factor b/library/eval-catch.factor index 6e40f2d90d..5a21024148 100644 --- a/library/eval-catch.factor +++ b/library/eval-catch.factor @@ -1,34 +1,6 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -IN: parser -USE: kernel -USE: errors -USE: stdio +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: parser USING: kernel errors stdio ; : eval-catch ( str -- ) [ eval ] [ [ print-error debug-help drop ] when* ] catch ; diff --git a/library/gensym.factor b/library/gensym.factor index cb561a6d41..e535018326 100644 --- a/library/gensym.factor +++ b/library/gensym.factor @@ -1,36 +1,6 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -IN: words -USE: kernel -USE: math -USE: namespaces -USE: strings -USE: unparser +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: words USING: kernel math namespaces strings unparser ; SYMBOL: gensym-count diff --git a/library/hashtables.factor b/library/hashtables.factor index fb3162dd42..b1480dc79e 100644 --- a/library/hashtables.factor +++ b/library/hashtables.factor @@ -1,36 +1,6 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! ! Copyright (C) 2004, 2005 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -IN: hashtables -USE: generic -USE: kernel -USE: lists -USE: math -USE: vectors +! See http://factor.sf.net/license.txt for BSD license. +IN: hashtables USING: generic kernel lists math vectors ; BUILTIN: hashtable 10 @@ -186,3 +156,10 @@ M: hashtable = ( obj hash -- ? ) 2drop f ] ifte ] ifte ; + +M: hashtable hashcode ( hash -- n ) + dup bucket-count 0 number= [ + drop 0 + ] [ + 0 swap hash-bucket hashcode + ] ifte ; diff --git a/library/in-thread.factor b/library/in-thread.factor index 37ff962057..eef6acdbb0 100644 --- a/library/in-thread.factor +++ b/library/in-thread.factor @@ -1,35 +1,6 @@ -! :folding=none:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -IN: threads -USE: errors -USE: io-internals -USE: kernel -USE: lists +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: threads USING: errors io-internals kernel lists ; : in-thread ( quot -- ) #! Execute a quotation in a co-operative thread. The diff --git a/library/kernel.factor b/library/kernel.factor index 2bc2bd6f0a..d5e298a28e 100644 --- a/library/kernel.factor +++ b/library/kernel.factor @@ -1,34 +1,6 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! ! Copyright (C) 2004, 2005 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -IN: kernel-internals -USE: generic -USE: kernel -USE: vectors +! See http://factor.sf.net/license.txt for BSD license. +IN: kernel-internals USING: generic kernel vectors ; : dispatch ( n vtable -- ) #! This word is unsafe since n is not bounds-checked. Do not diff --git a/library/lists.factor b/library/lists.factor index 20265abfe2..8c5fcf1a2c 100644 --- a/library/lists.factor +++ b/library/lists.factor @@ -1,34 +1,6 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! ! Copyright (C) 2003, 2005 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -IN: lists -USE: generic -USE: kernel -USE: math +! See http://factor.sf.net/license.txt for BSD license. +IN: lists USING: generic kernel math ; : 2list ( a b -- [ a b ] ) unit cons ; diff --git a/library/namespaces.factor b/library/namespaces.factor index 32cad49a1a..93a4f99307 100644 --- a/library/namespaces.factor +++ b/library/namespaces.factor @@ -1,46 +1,18 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2003, 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! Copyright (C) 2003, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: namespaces -USE: hashtables -USE: kernel -USE: kernel-internals -USE: lists -USE: vectors -USE: math +USING: hashtables kernel kernel-internals lists vectors math ; ! Other languages have classes, objects, variables, etc. ! Factor has similar concepts. ! -! 5 "x" set -! "x" get 2 + . +! SYMBOL: x +! +! 5 x set +! x get 2 + . ! 7 -! 7 "x" set -! "x" get 2 + . +! 7 x set +! x get 2 + . ! 9 ! ! get ( name -- value ) and set ( value name -- ) search in diff --git a/library/primitives.factor b/library/primitives.factor index d0484b0f98..3594354fa5 100644 --- a/library/primitives.factor +++ b/library/primitives.factor @@ -1,54 +1,13 @@ -! :folding=none:collapseFolds=1: - -! $Id$ -! ! Copyright (C) 2004, 2005 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! See http://factor.sf.net/license.txt for BSD license. IN: alien -USE: hashtables DEFER: alien DEFER: dll -USE: alien -USE: assembler -USE: compiler -USE: errors -USE: files -USE: generic -USE: io-internals -USE: kernel -USE: kernel-internals -USE: lists -USE: math -USE: math-internals -USE: parser -USE: profiler -USE: random -USE: strings -USE: unparser -USE: vectors -USE: words +USING: alien assembler compiler errors files generic +io-internals kernel kernel-internals lists math math-internals +parser profiler random strings unparser vectors words +hashtables ; [ [ execute " word -- " f ] diff --git a/library/random.factor b/library/random.factor index b9ea85345c..616fdf2288 100644 --- a/library/random.factor +++ b/library/random.factor @@ -1,37 +1,8 @@ -! :folding=indent:collapseFolds=0: +! Copyright (C) 2003, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: random USING: kernel lists math ; -! $Id$ -! -! Copyright (C) 2003, 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -IN: random -USE: kernel -USE: lists -USE: math - -: power-of-2? ( n -- ? ) - dup dup neg bitand = ; +: power-of-2? ( n -- ? ) dup dup neg bitand = ; : (random-int-0) ( n bits val -- n ) 3dup - + 1 < [ @@ -47,11 +18,6 @@ USE: math (random-int) 2dup swap mod (random-int-0) ] ifte ; -: random-int ( min max -- n ) - dupd swap - random-int-0 + ; - -: random-boolean ( -- ? ) - 0 1 random-int 0 = ; - -: random-digit ( -- digit ) - 0 9 random-int ; +: random-int ( min max -- n ) dupd swap - random-int-0 + ; +: random-boolean ( -- ? ) 0 1 random-int 0 = ; +: random-digit ( -- digit ) 0 9 random-int ; diff --git a/library/sbuf.factor b/library/sbuf.factor index d8c8ad6953..3a9ab2c8cf 100644 --- a/library/sbuf.factor +++ b/library/sbuf.factor @@ -1,36 +1,6 @@ -! :folding=indent:collapseFolds=0: - -! $Id$ -! -! Copyright (C) 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -IN: strings -USE: kernel -USE: lists -USE: math -USE: namespaces -USE: strings +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: strings USING: kernel lists math namespaces strings ; : make-string ( quot -- string ) #! Call a quotation. The quotation can call , to prepend diff --git a/library/stack.factor b/library/stack.factor index 217ddf7169..4ff59bc860 100644 --- a/library/stack.factor +++ b/library/stack.factor @@ -1,30 +1,5 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: kernel : 2drop ( x x -- ) drop drop ; inline diff --git a/library/strings.factor b/library/strings.factor index c663c27b1f..46957765ff 100644 --- a/library/strings.factor +++ b/library/strings.factor @@ -1,36 +1,6 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2003, 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -IN: strings -USE: generic -USE: kernel -USE: kernel-internals -USE: lists -USE: math +! Copyright (C) 2003, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: strings USING: generic kernel kernel-internals lists math ; ! Define methods bound to primitives BUILTIN: string 12 diff --git a/library/syntax/parse-syntax.factor b/library/syntax/parse-syntax.factor index 7c08bee089..d9f03126d8 100644 --- a/library/syntax/parse-syntax.factor +++ b/library/syntax/parse-syntax.factor @@ -112,6 +112,12 @@ USE: unparser #! Add vocabulary to search path. scan "use" cons@ ; parsing +: USING: + #! A list of vocabularies terminated with ; + string-mode on + [ string-mode off [ "use" cons@ ] each ] + f ; parsing + : IN: #! Set vocabulary for new definitions. scan dup "use" cons@ "in" set ; parsing diff --git a/library/syntax/parser.factor b/library/syntax/parser.factor index 8af769b298..ff43e999e0 100644 --- a/library/syntax/parser.factor +++ b/library/syntax/parser.factor @@ -89,9 +89,16 @@ USE: unparser "col" get "line" get dup >r (scan) dup "col" set 2dup = [ r> 3drop f ] [ r> substring ] ifte ; +! If this variable is on, the parser does not internalize words; +! it just appends strings to the parse tree as they are read. +SYMBOL: string-mode +global [ string-mode off ] bind + : scan-word ( -- obj ) scan dup [ - dup "use" get search [ str>number ] ?unless + dup ";" = not string-mode get and [ + dup "use" get search [ str>number ] ?unless + ] unless ] when ; : parse-loop ( -- ) diff --git a/library/threads.factor b/library/threads.factor index f0b61d50e5..70089b39da 100644 --- a/library/threads.factor +++ b/library/threads.factor @@ -1,36 +1,7 @@ -! :folding=none:collapseFolds=1: - -! $Id$ -! ! Copyright (C) 2004, 2005 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! See http://factor.sf.net/license.txt for BSD license. IN: threads -USE: io-internals -USE: kernel -USE: kernel-internals -USE: lists -USE: namespaces +USING: io-internals kernel kernel-internals lists namespaces ; ! Core of the multitasker. Used by io-internals.factor and ! in-thread.factor. diff --git a/library/vectors.factor b/library/vectors.factor index 6853420256..54136147db 100644 --- a/library/vectors.factor +++ b/library/vectors.factor @@ -1,38 +1,8 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! ! Copyright (C) 2004, 2005 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! See http://factor.sf.net/license.txt for BSD license. IN: vectors -USE: generic -USE: kernel -USE: lists -USE: math -USE: kernel-internals -USE: errors -USE: math-internals +USING: generic kernel lists math kernel-internals errors +math-internals ; BUILTIN: vector 11 diff --git a/library/vocabularies.factor b/library/vocabularies.factor index f1d1e3178f..55c21d280b 100644 --- a/library/vocabularies.factor +++ b/library/vocabularies.factor @@ -1,36 +1,6 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -IN: words -USE: hashtables -USE: kernel -USE: lists -USE: namespaces -USE: strings +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: words USING: hashtables kernel lists namespaces strings ; : word ( -- word ) global [ "last-word" get ] bind ; : set-word ( word -- ) global [ "last-word" set ] bind ; @@ -100,32 +70,10 @@ USE: strings ! For interactive "scratchpad" "in" set [ - "compiler" - "debugger" - "errors" - "files" - "generic" - "hashtables" - "inference" - "interpreter" - "jedit" - "kernel" - "listener" - "lists" - "math" - "namespaces" - "parser" - "prettyprint" - "processes" - "profiler" - "streams" - "stdio" - "strings" - "syntax" - "test" - "threads" - "unparser" - "vectors" - "words" - "scratchpad" + "compiler" "debugger" "errors" "files" "generic" + "hashtables" "inference" "interpreter" "jedit" "kernel" + "listener" "lists" "math" "namespaces" "parser" + "prettyprint" "processes" "profiler" "streams" "stdio" + "strings" "syntax" "test" "threads" "unparser" "vectors" + "words" "scratchpad" ] "use" set ; diff --git a/library/words.factor b/library/words.factor index e05aa95fca..371b37e8f5 100644 --- a/library/words.factor +++ b/library/words.factor @@ -1,39 +1,8 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2003, 2005 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: words -USE: generic -USE: hashtables -USE: kernel -USE: kernel-internals -USE: lists -USE: math -USE: namespaces -USE: strings +USING: generic hashtables kernel kernel-internals lists math +namespaces strings ; BUILTIN: word 17 From 93dc7ce736de64ea1138ca7bbe3cbef43e7d2090 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Jan 2005 21:39:30 +0000 Subject: [PATCH 040/122] added new tuple metaclass, eventually to replace the traits metaclass --- TODO.FACTOR.txt | 1 + factor/parser/Using.java | 4 +- library/bootstrap/boot-stage2.factor | 36 +---------- library/bootstrap/boot.factor | 39 ++---------- library/bootstrap/primitives.factor | 41 ++---------- library/generic/builtin.factor | 2 +- library/generic/generic.factor | 78 ++++++----------------- library/generic/traits.factor | 2 +- library/generic/tuple.factor | 91 +++++++++++++++++++++++++++ library/kernel.factor | 4 +- library/namespaces.factor | 5 ++ library/primitives.factor | 1 + library/test/benchmark/vectors.factor | 2 +- native/array.c | 17 +++-- native/array.h | 3 +- native/factor.h | 4 +- native/gc.c | 1 + native/hashtable.c | 2 +- native/primitives.c | 3 +- native/relocate.c | 1 + native/types.c | 1 + native/types.h | 5 +- native/vector.c | 2 +- 23 files changed, 163 insertions(+), 182 deletions(-) create mode 100644 library/generic/tuple.factor diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 705daa5a99..be31f5fcbd 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -39,6 +39,7 @@ - maple-like: press enter at old commands to evaluate there - completion in the listener - special completion for USE:/IN: +- support USING: + i/o: diff --git a/factor/parser/Using.java b/factor/parser/Using.java index 9f36bfc470..b4af3a3d35 100644 --- a/factor/parser/Using.java +++ b/factor/parser/Using.java @@ -3,7 +3,7 @@ /* * $Id$ * - * Copyright (C) 2004 Slava Pestov. + * Copyright (C) 2005 Slava Pestov. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are met: @@ -44,7 +44,7 @@ public class Using extends FactorParsingDefinition for(;;) { Object next = reader.next(false,false); - if(next == null) + if(next == FactorScanner.EOF) reader.getScanner().error("Expected ;"); if(next.equals(";")) break; diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index d7cc3a86e3..2ba7557c7b 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -1,37 +1,6 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! ! Copyright (C) 2004, 2005 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -IN: init -USE: kernel -USE: lists -USE: parser -USE: stdio -USE: words -USE: namespaces +! See http://factor.sf.net/license.txt for BSD license. +USING: kernel lists parser stdio words namespaces ; "Cold boot in progress..." print @@ -44,6 +13,7 @@ USE: namespaces "/library/generic/union.factor" "/library/generic/complement.factor" "/library/generic/traits.factor" + "/library/generic/tuple.factor" "/version.factor" "/library/stack.factor" diff --git a/library/bootstrap/boot.factor b/library/bootstrap/boot.factor index 981d27daa9..64de946fe1 100644 --- a/library/bootstrap/boot.factor +++ b/library/bootstrap/boot.factor @@ -1,39 +1,7 @@ -! :folding=none:collapseFolds=1: - -! $Id$ -! ! Copyright (C) 2004, 2005 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -USE: lists -USE: image -USE: parser -USE: namespaces -USE: stdio -USE: kernel -USE: vectors -USE: words -USE: hashtables +! See http://factor.sf.net/license.txt for BSD license. +USING: lists image parser namespaces stdio kernel vectors +words hashtables ; "/library/bootstrap/primitives.factor" run-resource @@ -88,6 +56,7 @@ USE: hashtables "/library/generic/union.factor" parse-resource append, "/library/generic/complement.factor" parse-resource append, "/library/generic/traits.factor" parse-resource append, + "/library/generic/tuple.factor" parse-resource append, "/library/bootstrap/init.factor" parse-resource append, "/library/syntax/parse-syntax.factor" parse-resource append, diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor index 8484cc844a..744f4e7576 100644 --- a/library/bootstrap/primitives.factor +++ b/library/bootstrap/primitives.factor @@ -1,40 +1,8 @@ -! :folding=none:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: image -USE: kernel -USE: lists -USE: math -USE: namespaces -USE: parser -USE: words -USE: vectors -USE: hashtables -USE: generic +USING: kernel lists math namespaces parser words vectors +hashtables generic ; ! Bring up a bare cross-compiling vocabulary. "syntax" vocab @@ -226,6 +194,7 @@ vocabularies get [ [[ "kernel-internals" "grow-array" ]] [[ "hashtables" "" ]] [[ "kernel-internals" "" ]] + [[ "kernel-internals" "" ]] ] [ unswons create swap 1 + [ f define ] keep ] each drop diff --git a/library/generic/builtin.factor b/library/generic/builtin.factor index 9d53bb2f14..d61dc5369d 100644 --- a/library/generic/builtin.factor +++ b/library/generic/builtin.factor @@ -83,7 +83,7 @@ builtin [ 2drop t ] "class<" set-word-property : builtin-type ( n -- symbol ) unit classes get hash ; -: class ( obj -- class ) +M: object class ( obj -- class ) #! Analogous to the type primitive. Pushes the builtin #! class of an object. type builtin-type ; diff --git a/library/generic/generic.factor b/library/generic/generic.factor index 24cac9d733..83410dc1ef 100644 --- a/library/generic/generic.factor +++ b/library/generic/generic.factor @@ -1,50 +1,11 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: generic -USE: errors -USE: hashtables -USE: kernel -USE: kernel-internals -USE: lists -USE: namespaces -USE: parser -USE: strings -USE: words -USE: vectors -USE: math -USE: math-internals -USE: unparser +USING: errors hashtables kernel kernel-internals lists +namespaces parser strings words vectors math math-internals ; ! A simple single-dispatch generic word system. -! "if I say I'd rather eat cheese than shit... doesn't mean -! those are the only two things I can eat." - Tac - : predicate-word ( word -- word ) word-name "?" cat2 "in" get create ; @@ -60,7 +21,7 @@ USE: unparser ! The class of an object with traits is determined by the object ! identity of the traits method map. ! - metaclass: a metaclass is a symbol with a handful of word -! properties: "define-method" "builtin-types" "priority" +! properties: "builtin-types" "priority" ! Metaclasses have priority -- this induces an order in which ! methods are added to the vtable. @@ -107,12 +68,13 @@ USE: unparser >r 2dup r> unswons add-method ] each nip ; -: define-generic ( word vtable -- ) +: make-generic ( word vtable -- ) over "combination" word-property cons define-compound ; -: (define-method) ( definition class generic -- ) +: define-method ( class generic definition -- ) + -rot [ "methods" word-property set-hash ] keep dup - define-generic ; + make-generic ; : init-methods ( word -- ) dup "methods" word-property [ @@ -122,15 +84,14 @@ USE: unparser ] ifte ; ! Defining generic words -: (GENERIC) ( combination definer -- ) +: define-generic ( combination definer word -- ) #! Takes a combination parameter. A combination is a #! quotation that takes some objects and a vtable from the #! stack, and calls the appropriate row of the vtable. - CREATE [ swap "definer" set-word-property ] keep [ swap "combination" set-word-property ] keep dup init-methods - dup define-generic ; + dup make-generic ; : single-combination ( obj vtable -- ) >r dup type r> dispatch ; inline @@ -138,7 +99,8 @@ USE: unparser : GENERIC: #! GENERIC: bar creates a generic word bar. Add methods to #! the generic word using M:. - [ single-combination ] \ GENERIC: (GENERIC) ; parsing + [ single-combination ] + \ GENERIC: CREATE define-generic ; parsing : arithmetic-combination ( n n vtable -- ) #! Note that the numbers remain on the stack, possibly after @@ -150,19 +112,13 @@ USE: unparser #! the generic word using M:. 2GENERIC words dispatch on #! arithmetic types and should not be used for non-numerical #! types. - [ arithmetic-combination ] \ 2GENERIC: (GENERIC) ; parsing - -: define-method ( class -- quotation ) - #! In a vain attempt at something resembling a "meta object - #! protocol", we call the "define-method" word property with - #! stack ( class generic definition -- ). - metaclass "define-method" word-property - [ [ -rot (define-method) ] ] unless* ; + [ arithmetic-combination ] + \ 2GENERIC: CREATE define-generic ; parsing : M: ( -- class generic [ ] ) #! M: foo bar begins a definition of the bar generic word #! specialized to the foo type. - scan-word dup define-method scan-word swap [ ] ; parsing + scan-word scan-word [ define-method ] [ ] ; parsing ! Maps lists of builtin type numbers to class objects. SYMBOL: classes @@ -210,3 +166,5 @@ SYMBOL: object classes get set-hash ; classes get [ classes set ] unless + +GENERIC: class ( obj -- class ) diff --git a/library/generic/traits.factor b/library/generic/traits.factor index 2bafb8053c..12c2c88cf2 100644 --- a/library/generic/traits.factor +++ b/library/generic/traits.factor @@ -67,7 +67,7 @@ SYMBOL: delegate ] "add-method" set-word-property \ traits [ - drop vector "builtin-type" word-property unit + drop hashtable "builtin-type" word-property unit ] "builtin-supertypes" set-word-property \ traits 10 "priority" set-word-property diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor new file mode 100644 index 0000000000..e6224559d8 --- /dev/null +++ b/library/generic/tuple.factor @@ -0,0 +1,91 @@ +! Copyright (C) 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: generic +USING: words parser kernel namespaces lists strings +kernel-internals math hashtables errors ; + +: make-tuple ( class -- ) + dup "tuple-size" word-property + [ 0 swap set-array-nth ] keep ; + +: define-tuple-generic ( tuple word def -- ) + over >r \ single-combination \ GENERIC: r> define-generic + define-method ; + +: define-accessor ( word name n -- ) + >r [ >r dup word-name , "-" , r> , ] make-string + "in" get create r> [ slot ] cons define-tuple-generic ; + +: define-mutator ( word name n -- ) + >r [ "set-" , >r dup word-name , "-" , r> , ] make-string + "in" get create r> [ set-slot ] cons define-tuple-generic ; + +: define-field ( word name n -- ) + 3dup define-accessor define-mutator ; + +: tuple-predicate ( word -- ) + #! Make a foo? word for testing the tuple class at the top + #! of the stack. + dup predicate-word swap + [ swap dup tuple? [ class eq? ] [ 2drop f ] ifte ] cons + define-compound ; + +: define-tuple ( word fields -- ) + 2dup length 1 + "tuple-size" set-word-property + dup length [ 3 + ] project zip + [ uncons define-field ] each-with ; + +: TUPLE: + #! Followed by a tuple name, then field names, then ; + CREATE + dup intern-symbol + dup tuple-predicate + dup define-promise + dup tuple "metaclass" set-word-property + string-mode on + [ string-mode off define-tuple ] + f ; parsing + +: constructor-word ( word -- word ) + word-name "<" swap ">" cat3 "in" get create ; + +: tuple-constructor ( word def -- ) + over constructor-word >r + [ swap literal, \ make-tuple , append, ] make-list + r> swap define-compound ; + +: TC: + #! Followed by a tuple name, then constructor code, then ; + #! Constructor code executes with the empty tuple on the + #! stack. + scan-word [ tuple-constructor ] f ; parsing + +: tuple-dispatch ( object selector -- object quot ) + over class over "methods" word-property hash* dup [ + nip cdr ( method is defined ) + ] [ + ! drop delegate rot hash [ + ! swap tuple-dispatch ( check delegate ) + ! ] [ + [ undefined-method ] ( no delegate ) + ! ] ifte* + ] ifte ; + +: add-tuple-dispatch ( word vtable -- ) + >r unit [ car tuple-dispatch call ] cons tuple r> + set-vtable ; + +M: tuple class ( obj -- class ) 2 slot ; + +tuple [ + ( generic vtable definition class -- ) + 2drop add-tuple-dispatch +] "add-method" set-word-property + +tuple [ + drop tuple "builtin-type" word-property unit +] "builtin-supertypes" set-word-property + +tuple 10 "priority" set-word-property + +tuple [ 2drop t ] "class<" set-word-property diff --git a/library/kernel.factor b/library/kernel.factor index d5e298a28e..6002ab66c5 100644 --- a/library/kernel.factor +++ b/library/kernel.factor @@ -7,6 +7,8 @@ IN: kernel-internals USING: generic kernel vectors ; #! call it directly. vector-array array-nth call ; +BUILTIN: tuple 18 + IN: kernel GENERIC: hashcode ( obj -- n ) @@ -32,7 +34,7 @@ M: object clone ; : num-types ( -- n ) #! One more than the maximum value from type primitive. - 18 ; + 19 ; : ? ( cond t f -- t/f ) #! Push t if cond is true, otherwise push f. diff --git a/library/namespaces.factor b/library/namespaces.factor index 93a4f99307..1519c2fdd0 100644 --- a/library/namespaces.factor +++ b/library/namespaces.factor @@ -141,3 +141,8 @@ SYMBOL: list-buffer : append, ( list -- ) [ , ] each ; + +: literal, ( word -- ) + #! Append some code that pushes the word on the stack. Used + #! when building quotations. + unit , \ car , ; diff --git a/library/primitives.factor b/library/primitives.factor index 3594354fa5..3a9f4d3b80 100644 --- a/library/primitives.factor +++ b/library/primitives.factor @@ -184,6 +184,7 @@ hashtables ; [ grow-array [ [ integer array ] [ object ] ] ] [ [ [ number ] [ hashtable ] ] ] [ [ [ number ] [ array ] ] ] + [ [ [ number ] [ tuple ] ] ] ] [ 2unlist dup string? [ "stack-effect" set-word-property diff --git a/library/test/benchmark/vectors.factor b/library/test/benchmark/vectors.factor index 8d6a767991..2afe570946 100644 --- a/library/test/benchmark/vectors.factor +++ b/library/test/benchmark/vectors.factor @@ -20,4 +20,4 @@ USE: test : vector-benchmark ( n -- ) 0 over fill-vector rot copy-vector ; compiled -[ ] [ 4000000 vector-benchmark ] unit-test +[ ] [ 400000 vector-benchmark ] unit-test diff --git a/native/array.c b/native/array.c index 191d234470..d7e7b97510 100644 --- a/native/array.c +++ b/native/array.c @@ -10,11 +10,11 @@ F_ARRAY* allot_array(CELL type, CELL capacity) } /* untagged */ -F_ARRAY* array(CELL capacity, CELL fill) +F_ARRAY* array(CELL type, CELL capacity, CELL fill) { int i; - F_ARRAY* array = allot_array(ARRAY_TYPE, capacity); + F_ARRAY* array = allot_array(type, capacity); for(i = 0; i < capacity; i++) put(AREF(array,i),fill); @@ -28,7 +28,16 @@ void primitive_array(void) if(capacity < 0) general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_fixnum(capacity)); maybe_garbage_collection(); - dpush(tag_object(array(capacity,F))); + dpush(tag_object(array(ARRAY_TYPE,capacity,F))); +} + +void primitive_tuple(void) +{ + F_FIXNUM capacity = to_fixnum(dpop()); + if(capacity < 0) + general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_fixnum(capacity)); + maybe_garbage_collection(); + dpush(tag_object(array(TUPLE_TYPE,capacity,F))); } F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill) @@ -43,7 +52,7 @@ F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill) new_array = allot_array(untag_header(array->header),capacity); - memcpy(new_array + 1,array + 1,array->capacity * CELLS); + memcpy(new_array + 1,array + 1,curr_cap * CELLS); for(i = curr_cap; i < capacity; i++) put(AREF(new_array,i),fill); diff --git a/native/array.h b/native/array.h index 28d71a4b41..7f048c0f0f 100644 --- a/native/array.h +++ b/native/array.h @@ -11,8 +11,9 @@ INLINE F_ARRAY* untag_array(CELL tagged) } F_ARRAY* allot_array(CELL type, CELL capacity); -F_ARRAY* array(CELL capacity, CELL fill); +F_ARRAY* array(CELL type, CELL capacity, CELL fill); void primitive_array(void); +void primitive_tuple(void); F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill); void primitive_grow_array(void); F_ARRAY* shrink_array(F_ARRAY* array, CELL capacity); diff --git a/native/factor.h b/native/factor.h index 49f7ed2a60..d0749dc2be 100644 --- a/native/factor.h +++ b/native/factor.h @@ -101,8 +101,8 @@ DLLEXPORT CELL cs; typedef unsigned char BYTE; /* Memory areas */ -#define DEFAULT_ARENA (64 * 1024 * 1024) -#define COMPILE_ZONE_SIZE (64 * 1024 * 1024) +#define DEFAULT_ARENA (8 * 1024 * 1024) +#define COMPILE_ZONE_SIZE (8 * 1024 * 1024) #define STACK_SIZE (2 * 1024 * 1024) #include "memory.h" diff --git a/native/gc.c b/native/gc.c index 5e2c880970..6c33083a43 100644 --- a/native/gc.c +++ b/native/gc.c @@ -69,6 +69,7 @@ INLINE void collect_object(CELL scan) collect_word((F_WORD*)scan); break; case ARRAY_TYPE: + case TUPLE_TYPE: collect_array((F_ARRAY*)scan); break; case HASHTABLE_TYPE: diff --git a/native/hashtable.c b/native/hashtable.c index cb27bd4c01..25ce2e72bc 100644 --- a/native/hashtable.c +++ b/native/hashtable.c @@ -7,7 +7,7 @@ F_HASHTABLE* hashtable(F_FIXNUM capacity) general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_fixnum(capacity)); hash = allot_object(HASHTABLE_TYPE,sizeof(F_VECTOR)); hash->count = tag_fixnum(0); - hash->array = tag_object(array(capacity,F)); + hash->array = tag_object(array(ARRAY_TYPE,capacity,F)); return hash; } diff --git a/native/primitives.c b/native/primitives.c index bf0723d7a9..3a426e454c 100644 --- a/native/primitives.c +++ b/native/primitives.c @@ -175,7 +175,8 @@ void* primitives[] = { primitive_set_integer_slot, primitive_grow_array, primitive_hashtable, - primitive_array + primitive_array, + primitive_tuple }; CELL primitive_to_xt(CELL primitive) diff --git a/native/relocate.c b/native/relocate.c index c6dfd0e73b..63abe8940c 100644 --- a/native/relocate.c +++ b/native/relocate.c @@ -8,6 +8,7 @@ void relocate_object(CELL relocating) fixup_word((F_WORD*)relocating); break; case ARRAY_TYPE: + case TUPLE_TYPE: fixup_array((F_ARRAY*)relocating); break; case HASHTABLE_TYPE: diff --git a/native/types.c b/native/types.c index a4048d22ed..d034b67be2 100644 --- a/native/types.c +++ b/native/types.c @@ -53,6 +53,7 @@ CELL untagged_object_size(CELL pointer) break; case ARRAY_TYPE: case BIGNUM_TYPE: + case TUPLE_TYPE: size = ASIZE(pointer); break; case HASHTABLE_TYPE: diff --git a/native/types.h b/native/types.h index ac481e47da..a5c51fb60a 100644 --- a/native/types.h +++ b/native/types.h @@ -12,7 +12,7 @@ #define RATIO_TYPE 4 #define FLOAT_TYPE 5 #define COMPLEX_TYPE 6 -#define HEADER_TYPE 7 +#define HEADER_TYPE 7 /* anything less than this is a tag */ #define GC_COLLECTED 7 /* See gc.c */ /*** Header types ***/ @@ -35,8 +35,9 @@ CELL T; #define DLL_TYPE 15 #define ALIEN_TYPE 16 #define WORD_TYPE 17 +#define TUPLE_TYPE 18 -#define TYPE_COUNT 18 +#define TYPE_COUNT 19 INLINE bool headerp(CELL cell) { diff --git a/native/vector.c b/native/vector.c index 010c1f6b58..e75b6b4ffc 100644 --- a/native/vector.c +++ b/native/vector.c @@ -7,7 +7,7 @@ F_VECTOR* vector(F_FIXNUM capacity) general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_fixnum(capacity)); vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR)); vector->top = tag_fixnum(0); - vector->array = tag_object(array(capacity,F)); + vector->array = tag_object(array(ARRAY_TYPE,capacity,F)); return vector; } From 330db0497d6c49f943a7de0288edab34714ad3d6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Jan 2005 20:57:25 +0000 Subject: [PATCH 041/122] tuples used for i/o streams, removed traits metaclass --- factor/ExternalFactor.java | 28 ++++--- library/bootstrap/boot-stage2.factor | 1 - library/bootstrap/boot.factor | 3 - library/bootstrap/primitives.factor | 2 + library/compiler/alien.factor | 53 ++----------- library/generic/generic.factor | 4 - library/generic/traits.factor | 104 -------------------------- library/generic/tuple.factor | 51 +++++++++---- library/httpd/html.factor | 47 ++---------- library/httpd/httpd.factor | 45 ++--------- library/inference/branches.factor | 49 ++---------- library/inference/inference.factor | 53 ++++++------- library/inference/types.factor | 48 ++---------- library/inference/words.factor | 44 +---------- library/io/ansi.factor | 61 +++------------ library/io/io-internals.factor | 2 - library/io/logging.factor | 7 +- library/io/network.factor | 61 ++++----------- library/io/stdio.factor | 53 ++----------- library/io/stream-impl.factor | 62 ++++----------- library/io/stream.factor | 88 ++++++---------------- library/primitives.factor | 2 + library/test/benchmark/strings.factor | 2 +- library/test/generic.factor | 54 ------------- library/test/stream.factor | 31 -------- library/tools/debugger.factor | 4 +- library/tools/jedit-wire.factor | 10 ++- library/tools/telnetd.factor | 46 ++---------- library/ui/console.factor | 41 ++++------ native/array.c | 10 +++ native/array.h | 2 + native/debug.c | 40 +++++++++- native/primitives.c | 4 +- 33 files changed, 273 insertions(+), 839 deletions(-) delete mode 100644 library/generic/traits.factor diff --git a/factor/ExternalFactor.java b/factor/ExternalFactor.java index 6d6f6a6afc..78b5779ae9 100644 --- a/factor/ExternalFactor.java +++ b/factor/ExternalFactor.java @@ -63,8 +63,7 @@ public class ExternalFactor extends DefaultVocabularyLookup } Log.log(Log.ERROR,this,"Cannot connect to Factor on port " + port); - if(in != null && out != null) - close(); + close(); } //}}} //{{{ openWireSocket() method @@ -280,21 +279,26 @@ public class ExternalFactor extends DefaultVocabularyLookup closed = true; - try + if(out != null) { - /* don't care about response */ - sendEval("0 exit*"); - } - catch(Exception e) - { - // We don't care... - Log.log(Log.DEBUG,this,e); + try + { + /* don't care about response */ + sendEval("0 exit*"); + } + catch(Exception e) + { + // We don't care... + Log.log(Log.DEBUG,this,e); + } } try { - in.close(); - out.close(); + if(in != null) + in.close(); + if(out != null) + out.close(); } catch(Exception e) { diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index 2ba7557c7b..9e7e0e142b 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -12,7 +12,6 @@ USING: kernel lists parser stdio words namespaces ; "/library/generic/predicate.factor" "/library/generic/union.factor" "/library/generic/complement.factor" - "/library/generic/traits.factor" "/library/generic/tuple.factor" "/version.factor" diff --git a/library/bootstrap/boot.factor b/library/bootstrap/boot.factor index 64de946fe1..43d49a61b9 100644 --- a/library/bootstrap/boot.factor +++ b/library/bootstrap/boot.factor @@ -38,13 +38,11 @@ words hashtables ; "/library/syntax/parser.factor" parse-resource append, "/library/syntax/parse-stream.factor" parse-resource append, - "traits" [ "generic" ] search "delegate" [ "generic" ] search "object" [ "generic" ] search vocabularies get [ "generic" off ] bind - reveal reveal reveal @@ -55,7 +53,6 @@ words hashtables ; "/library/generic/predicate.factor" parse-resource append, "/library/generic/union.factor" parse-resource append, "/library/generic/complement.factor" parse-resource append, - "/library/generic/traits.factor" parse-resource append, "/library/generic/tuple.factor" parse-resource append, "/library/bootstrap/init.factor" parse-resource append, diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor index 744f4e7576..0ea76fd777 100644 --- a/library/bootstrap/primitives.factor +++ b/library/bootstrap/primitives.factor @@ -195,6 +195,8 @@ vocabularies get [ [[ "hashtables" "" ]] [[ "kernel-internals" "" ]] [[ "kernel-internals" "" ]] + [[ "kernel-internals" ">array" ]] + [[ "kernel-internals" ">tuple" ]] ] [ unswons create swap 1 + [ f define ] keep ] each drop diff --git a/library/compiler/alien.factor b/library/compiler/alien.factor index 056ae65cc7..67e42248e7 100644 --- a/library/compiler/alien.factor +++ b/library/compiler/alien.factor @@ -1,46 +1,9 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! ! Copyright (C) 2004, 2005 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! See http://factor.sf.net/license.txt for BSD license. IN: alien -USE: assembler -USE: compiler -USE: errors -USE: generic -USE: inference -USE: interpreter -USE: kernel -USE: lists -USE: math -USE: namespaces -USE: parser -USE: words -USE: hashtables -USE: strings -USE: unparser +USING: assembler compiler errors generic inference interpreter +kernel lists math namespaces parser words hashtables strings +unparser ; ! Command line parameters specify libraries to load. ! @@ -133,10 +96,10 @@ SYMBOL: alien-parameters : infer-alien ( -- ) [ object object object object ] ensure-d - dataflow-drop, pop-d literal-value - dataflow-drop, pop-d literal-value >r - dataflow-drop, pop-d literal-value - dataflow-drop, pop-d literal-value -rot + dataflow-drop, pop-d value-literal + dataflow-drop, pop-d value-literal >r + dataflow-drop, pop-d value-literal + dataflow-drop, pop-d value-literal -rot r> swap alien-node ; : box-parameter diff --git a/library/generic/generic.factor b/library/generic/generic.factor index 83410dc1ef..4aed76f502 100644 --- a/library/generic/generic.factor +++ b/library/generic/generic.factor @@ -16,10 +16,6 @@ namespaces parser strings words vectors math math-internals ; ! - class: a user defined way of differentiating objects, either ! based on type, or some combination of type, predicate, or ! method map. -! - traits: a hashtable has traits of its traits slot is set to -! a hashtable mapping selector names to method definitions. -! The class of an object with traits is determined by the object -! identity of the traits method map. ! - metaclass: a metaclass is a symbol with a handful of word ! properties: "builtin-types" "priority" diff --git a/library/generic/traits.factor b/library/generic/traits.factor deleted file mode 100644 index 12c2c88cf2..0000000000 --- a/library/generic/traits.factor +++ /dev/null @@ -1,104 +0,0 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -IN: generic -USE: errors -USE: hashtables -USE: kernel -USE: lists -USE: namespaces -USE: parser -USE: strings -USE: words -USE: vectors - -! Traits metaclass for user-defined classes based on hashtables - -: traits ( object -- symbol ) - dup hashtable? [ \ traits swap hash ] [ drop f ] ifte ; - -! Hashtable slot holding an optional delegate. Any undefined -! methods are called on the delegate. The object can also -! manually pass any methods on to the delegate. -SYMBOL: delegate - -: traits-dispatch ( object selector -- object quot ) - over traits over "methods" word-property hash* dup [ - nip cdr ( method is defined ) - ] [ - drop delegate rot hash [ - swap traits-dispatch ( check delegate ) - ] [ - [ undefined-method ] ( no delegate ) - ] ifte* - ] ifte ; - -: add-traits-dispatch ( word vtable -- ) - >r unit [ car traits-dispatch call ] cons \ hashtable r> - set-vtable ; - -\ traits [ - ( generic vtable definition class -- ) - 2drop add-traits-dispatch -] "add-method" set-word-property - -\ traits [ - drop hashtable "builtin-type" word-property unit -] "builtin-supertypes" set-word-property - -\ traits 10 "priority" set-word-property - -\ traits [ 2drop t ] "class<" set-word-property - -: traits-predicate ( word -- ) - #! foo? where foo is a traits type tests if the top of stack - #! is of this type. - dup predicate-word swap - [ swap traits eq? ] cons - define-compound ; - -: TRAITS: - #! TRAITS: foo creates a new traits type. Instances can be - #! created with , and tested with foo?. - CREATE - dup define-symbol - dup \ traits "metaclass" set-word-property - traits-predicate ; parsing - -: constructor-word ( word -- word ) - word-name "<" swap ">" cat3 "in" get create ; - -: define-constructor ( constructor traits definition -- ) - >r - [ \ traits pick set-hash ] cons \ swons - r> append define-compound ; - -: C: ( -- constructor traits [ ] ) - #! C: foo ... begins definition for where foo is a - #! traits type. - scan-word [ constructor-word ] keep - [ define-constructor ] [ ] ; parsing diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor index e6224559d8..a47adedad0 100644 --- a/library/generic/tuple.factor +++ b/library/generic/tuple.factor @@ -9,7 +9,7 @@ kernel-internals math hashtables errors ; [ 0 swap set-array-nth ] keep ; : define-tuple-generic ( tuple word def -- ) - over >r \ single-combination \ GENERIC: r> define-generic + over >r [ single-combination ] \ GENERIC: r> define-generic define-method ; : define-accessor ( word name n -- ) @@ -21,6 +21,9 @@ kernel-internals math hashtables errors ; "in" get create r> [ set-slot ] cons define-tuple-generic ; : define-field ( word name n -- ) + over "delegate" = [ + pick over "delegate-field" set-word-property + ] when 3dup define-accessor define-mutator ; : tuple-predicate ( word -- ) @@ -35,13 +38,15 @@ kernel-internals math hashtables errors ; dup length [ 3 + ] project zip [ uncons define-field ] each-with ; -: TUPLE: - #! Followed by a tuple name, then field names, then ; - CREATE +: begin-tuple ( word -- ) dup intern-symbol dup tuple-predicate dup define-promise - dup tuple "metaclass" set-word-property + tuple "metaclass" set-word-property ; + +: TUPLE: + #! Followed by a tuple name, then field names, then ; + CREATE dup begin-tuple string-mode on [ string-mode off define-tuple ] f ; parsing @@ -54,22 +59,40 @@ kernel-internals math hashtables errors ; [ swap literal, \ make-tuple , append, ] make-list r> swap define-compound ; -: TC: +: wrapper-constructor ( word -- quot ) + "delegate-field" word-property [ set-slot ] cons + [ keep ] cons ; + +: WRAPPER: + #! A wrapper is a tuple whose only slot is a delegate slot. + CREATE dup begin-tuple + dup [ "delegate" ] define-tuple + dup wrapper-constructor + tuple-constructor ; parsing + +: C: #! Followed by a tuple name, then constructor code, then ; #! Constructor code executes with the empty tuple on the #! stack. scan-word [ tuple-constructor ] f ; parsing -: tuple-dispatch ( object selector -- object quot ) - over class over "methods" word-property hash* dup [ - nip cdr ( method is defined ) +: tuple-delegate ( tuple -- obj ) + >tuple dup class "delegate-field" word-property dup [ + >fixnum slot ] [ - ! drop delegate rot hash [ - ! swap tuple-dispatch ( check delegate ) - ! ] [ + 2drop f + ] ifte ; inline + +: tuple-dispatch ( object selector -- object quot ) + over class over "methods" word-property hash* [ + cdr ( method is defined ) + ] [ + over tuple-delegate [ + rot drop swap tuple-dispatch ( check delegate ) + ] [ [ undefined-method ] ( no delegate ) - ! ] ifte* - ] ifte ; + ] ifte* + ] ?ifte ; : add-tuple-dispatch ( word vtable -- ) >r unit [ car tuple-dispatch call ] cons tuple r> diff --git a/library/httpd/html.factor b/library/httpd/html.factor index 3d9fd7cd95..63946c13d1 100644 --- a/library/httpd/html.factor +++ b/library/httpd/html.factor @@ -1,41 +1,8 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: html -USE: lists -USE: kernel -USE: namespaces -USE: stdio -USE: streams -USE: strings -USE: unparser -USE: url-encoding -USE: presentation -USE: generic +USING: lists kernel namespaces stdio streams strings unparser +url-encoding presentation generic ; : html-entities ( -- alist ) [ @@ -120,10 +87,10 @@ USE: generic drop call ] ifte ; -TRAITS: html-stream +TUPLE: html-stream delegate ; M: html-stream fwrite-attr ( str style stream -- ) - [ + wrapper-stream-scope [ [ [ [ drop chars>entities write ] span-tag @@ -145,7 +112,7 @@ C: html-stream ( stream -- stream ) #! underline #! size #! link - an object path - [ dup delegate set stdio set ] extend ; + [ >r r> set-html-stream-delegate ] keep ; : with-html-stream ( quot -- ) [ stdio [ ] change call ] with-scope ; diff --git a/library/httpd/httpd.factor b/library/httpd/httpd.factor index 2d597f79fe..c4faf202da 100644 --- a/library/httpd/httpd.factor +++ b/library/httpd/httpd.factor @@ -1,42 +1,8 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2003, 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! Copyright (C) 2003, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: httpd -USE: errors -USE: httpd-responder -USE: kernel -USE: lists -USE: logging -USE: namespaces -USE: stdio -USE: streams -USE: strings -USE: threads -USE: url-encoding +USING: errors httpd-responder kernel lists logging namespaces +stdio streams strings threads url-encoding ; : httpd-log-stream ( -- stream ) #! Set httpd-log-file to save httpd log to a file. @@ -83,8 +49,7 @@ USE: url-encoding : httpd-client ( socket -- ) [ [ - stdio get "client" set log-client - read [ parse-request ] when* + stdio get log-client read [ parse-request ] when* ] with-stream ] try ; diff --git a/library/inference/branches.factor b/library/inference/branches.factor index c5cff70a5f..2dd5b5b3bb 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -1,43 +1,8 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! ! Copyright (C) 2004, 2005 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! See http://factor.sf.net/license.txt for BSD license. IN: inference -USE: errors -USE: generic -USE: interpreter -USE: kernel -USE: lists -USE: math -USE: namespaces -USE: strings -USE: vectors -USE: words -USE: hashtables -USE: prettyprint +USING: errors generic interpreter kernel lists math namespaces +strings vectors words hashtables prettyprint ; : longest-vector ( list -- length ) [ vector-length ] map [ > ] top ; @@ -140,7 +105,7 @@ SYMBOL: cloned #! Type propagation is chained. [ unswons 2dup set-value-class - [ type-propagations get ] bind assoc propagate-type + value-type-prop assoc propagate-type ] when* ; : infer-branch ( value -- namespace ) @@ -148,7 +113,7 @@ SYMBOL: cloned uncons propagate-type dup value-recursion recursive-state set copy-inference - literal-value dup infer-quot + value-literal dup infer-quot #values values-node handle-terminator ] extend ; @@ -212,7 +177,7 @@ SYMBOL: cloned dataflow-drop, pop-d boolean-value [ drop ] [ nip ] ifte gensym [ dup value-recursion recursive-state set - literal-value infer-quot + value-literal infer-quot ] (with-block) drop ; : dynamic-ifte ( true false -- ) @@ -239,7 +204,7 @@ SYMBOL: cloned \ ifte [ infer-ifte ] "infer" set-word-property : vtable>list ( value -- list ) - dup value-recursion swap literal-value vector>list + dup value-recursion swap value-literal vector>list [ over ] map nip ; USE: kernel-internals diff --git a/library/inference/inference.factor b/library/inference/inference.factor index 076832d913..4f35dda879 100644 --- a/library/inference/inference.factor +++ b/library/inference/inference.factor @@ -60,57 +60,46 @@ SYMBOL: d-in ! Recursive state. An alist, mapping words to labels. SYMBOL: recursive-state -GENERIC: literal-value ( value -- obj ) GENERIC: value= ( literal value -- ? ) -GENERIC: value-class ( value -- class ) GENERIC: value-class-and ( class value -- ) -GENERIC: set-value-class ( class value -- ) ! A value has the following slots in addition to those relating ! to generics above: -! An association list mapping values to [[ value class ]] pairs -SYMBOL: type-propagations +TUPLE: value literal class type-prop recursion ; +C: value ; + +TUPLE: computed delegate ; -TRAITS: computed C: computed ( class -- value ) - [ - \ value-class set - gensym \ literal-value set - type-propagations off - ] extend ; -M: computed literal-value ( value -- obj ) + over set-computed-delegate + [ set-value-class ] keep ; + +M: computed value-literal ( value -- obj ) "Cannot use a computed value literally." throw ; + M: computed value= ( literal value -- ? ) 2drop f ; -M: computed value-class ( value -- class ) - [ \ value-class get ] bind ; -M: computed value-class-and ( class value -- ) - [ \ value-class [ class-and ] change ] bind ; -M: computed set-value-class ( class value -- ) - [ \ value-class set ] bind ; -TRAITS: literal +M: computed value-class-and ( class value -- ) + [ value-class class-and ] keep set-value-class ; + +TUPLE: literal delegate ; + C: literal ( obj rstate -- value ) - [ - recursive-state set - \ literal-value set - type-propagations off - ] extend ; -M: literal literal-value ( value -- obj ) - [ \ literal-value get ] bind ; + over set-literal-delegate + [ set-value-recursion ] keep + [ set-value-literal ] keep ; + M: literal value= ( literal value -- ? ) - literal-value = ; -M: literal value-class ( value -- class ) - literal-value class ; + value-literal = ; + M: literal value-class-and ( class value -- ) value-class class-and drop ; + M: literal set-value-class ( class value -- ) 2drop ; -: value-recursion ( value -- rstate ) - [ recursive-state get ] bind ; - : (ensure-types) ( typelist n stack -- ) pick [ 3dup >r >r car r> r> vector-nth value-class-and diff --git a/library/inference/types.factor b/library/inference/types.factor index 7acdc8e7b8..b6a1c377eb 100644 --- a/library/inference/types.factor +++ b/library/inference/types.factor @@ -1,44 +1,8 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: inference -USE: errors -USE: generic -USE: interpreter -USE: kernel -USE: kernel-internals -USE: lists -USE: math -USE: namespaces -USE: strings -USE: vectors -USE: words -USE: stdio -USE: prettyprint +USING: errors generic interpreter kernel kernel-internals +lists math namespaces strings vectors words stdio prettyprint ; ! Enhanced inference of primitives relating to data types. ! Optimizes type checks and slot access. @@ -65,7 +29,7 @@ USE: prettyprint ! \ slot [ ! [ object fixnum ] ensure-d -! dataflow-drop, pop-d literal-value +! dataflow-drop, pop-d value-literal ! peek-d value-class builtin-supertypes dup length 1 = [ ! cons \ slot [ [ object ] [ object ] ] (consume/produce) ! ] [ @@ -84,7 +48,7 @@ USE: prettyprint 1 0 node-inputs [ object ] consume-d [ fixnum ] produce-d - r> peek-d [ type-propagations set ] bind + r> peek-d value-type-prop 1 0 node-outputs ] bind ] "infer" set-word-property diff --git a/library/inference/words.factor b/library/inference/words.factor index 21b1f3f50f..35d55fd2f9 100644 --- a/library/inference/words.factor +++ b/library/inference/words.factor @@ -1,44 +1,8 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! ! Copyright (C) 2004, 2005 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! See http://factor.sf.net/license.txt for BSD license. IN: inference -USE: errors -USE: generic -USE: interpreter -USE: kernel -USE: lists -USE: math -USE: namespaces -USE: strings -USE: vectors -USE: words -USE: hashtables -USE: parser -USE: prettyprint +USING: errors generic interpreter kernel lists math namespaces +strings vectors words hashtables parser prettyprint ; : with-dataflow ( param op [[ in# out# ]] quot -- ) #! Take input parameters, execute quotation, take output @@ -194,7 +158,7 @@ M: symbol (apply-word) ( word -- ) gensym dup [ drop pop-d dup value-recursion recursive-state set - literal-value infer-quot + value-literal infer-quot ] with-block drop ; \ call [ infer-call ] "infer" set-word-property diff --git a/library/io/ansi.factor b/library/io/ansi.factor index bd3d00dfd9..3a47e40ae6 100644 --- a/library/io/ansi.factor +++ b/library/io/ansi.factor @@ -1,41 +1,14 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: ansi -USE: lists -USE: kernel -USE: namespaces -USE: stdio -USE: streams -USE: strings -USE: presentation -USE: generic +USING: lists kernel namespaces stdio streams strings +presentation generic ; -! Some words for outputting ANSI colors. +! raps the given stream in an ANSI stream. ANSI +! streams support the following character attributes: +! bold - if not f, text is boldface. +! ansi-fg - foreground color +! ansi-bg - background color ! black 0 ! red 1 @@ -75,21 +48,11 @@ USE: generic : ansi-attr-string ( string style -- string ) [ ansi-attrs , reset , ] make-string ; -TRAITS: ansi-stream +WRAPPER: ansi-stream M: ansi-stream fwrite-attr ( string style stream -- ) - [ - [ default-style ] unless* ansi-attr-string - delegate get fwrite - ] bind ; - -C: ansi-stream ( stream -- stream ) - #! Wraps the given stream in an ANSI stream. ANSI streams - #! support the following character attributes: - #! bold - if not f, text is boldface. - #! ansi-fg - foreground color - #! ansi-bg - background color - [ delegate set ] extend ; + >r [ default-style ] unless* ansi-attr-string r> + ansi-stream-delegate fwrite ; IN: shells diff --git a/library/io/io-internals.factor b/library/io/io-internals.factor index aa0f840320..b0e55c2f83 100644 --- a/library/io/io-internals.factor +++ b/library/io/io-internals.factor @@ -76,5 +76,3 @@ BUILTIN: port 14 : blocking-copy ( in out -- ) [ add-copy-io-task (yield) ] callcc0 pending-io-error pending-io-error ; - - diff --git a/library/io/logging.factor b/library/io/logging.factor index 4627bc6a53..79e4a3881f 100644 --- a/library/io/logging.factor +++ b/library/io/logging.factor @@ -41,10 +41,9 @@ USE: unparser : log-error ( error -- ) "Error: " swap cat2 log ; -: log-client ( -- ) - "client" get [ - "Accepted connection from " swap - "client" swap hash cat2 log +: log-client ( client-stream -- ) + client-stream-host [ + "Accepted connection from " swap cat2 log ] when* ; : with-logging ( quot -- ) diff --git a/library/io/network.factor b/library/io/network.factor index 2350719fed..cbca2aab53 100644 --- a/library/io/network.factor +++ b/library/io/network.factor @@ -1,61 +1,32 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: streams -USE: io-internals -USE: errors -USE: hashtables -USE: kernel -USE: stdio -USE: strings -USE: namespaces -USE: unparser -USE: generic +USING: io-internals errors hashtables kernel stdio strings +namespaces unparser generic ; -TRAITS: server +TUPLE: server port ; GENERIC: accept M: server fclose ( stream -- ) - [ "socket" get close-port ] bind ; + server-port close-port ; C: server ( port -- stream ) #! Starts listening on localhost:port. Returns a stream that #! you can close with fclose, and accept connections from #! with accept. No other stream operations are supported. - [ server-socket "socket" set ] extend ; + [ >r server-socket r> set-server-port ] keep ; -: ( host port in out -- stream ) - [ ":" swap unparse cat3 "client" set ] extend ; +TUPLE: client-stream delegate host ; + +C: client-stream ( host port in out -- stream ) + #! fflush yields until connection is established. + [ >r r> set-client-stream-delegate ] keep + [ >r ":" swap unparse cat3 r> set-client-stream-host ] keep + dup fflush ; : ( host port -- stream ) - #! fflush yields until connection is established. - 2dup client-socket dup fflush ; + 2dup client-socket ; M: server accept ( server -- client ) #! Accept a connection from a server socket. - "socket" swap hash blocking-accept ; - + server-port blocking-accept ; diff --git a/library/io/stdio.factor b/library/io/stdio.factor index df04ef1a40..bf63838666 100644 --- a/library/io/stdio.factor +++ b/library/io/stdio.factor @@ -1,38 +1,7 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2003, 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! Copyright (C) 2003, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: stdio -USE: errors -USE: kernel -USE: lists -USE: namespaces -USE: streams -USE: generic -USE: strings +USING: errors kernel lists namespaces streams generic strings ; SYMBOL: stdio @@ -56,24 +25,14 @@ SYMBOL: stdio : with-string ( quot -- str ) #! Execute a quotation, and push a string containing all #! text printed by the quotation. - 1024 [ + 1024 [ call stdio get stream>str ] with-stream ; -TRAITS: stdio-stream +WRAPPER: stdio-stream M: stdio-stream fauto-flush ( -- ) - [ delegate get fflush ] bind ; + stdio-stream-delegate fflush ; M: stdio-stream fclose ( -- ) drop ; - -C: stdio-stream ( delegate -- stream ) - [ delegate set ] extend ; - -: with-prefix ( prefix quot -- ) - #! Each line of output from the given quotation is prefixed - #! with a string. - swap stdio get [ - stdio set call - ] with-scope ; inline diff --git a/library/io/stream-impl.factor b/library/io/stream-impl.factor index a69eb54885..55db952403 100644 --- a/library/io/stream-impl.factor +++ b/library/io/stream-impl.factor @@ -1,68 +1,36 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: stdio DEFER: stdio IN: streams -USE: io-internals -USE: errors -USE: hashtables -USE: kernel -USE: stdio -USE: strings -USE: namespaces -USE: generic +USING: io-internals errors hashtables kernel stdio strings +namespaces generic ; -TRAITS: fd-stream +TUPLE: fd-stream in out ; M: fd-stream fwrite-attr ( str style stream -- ) - [ drop "out" get blocking-write ] bind ; + nip fd-stream-out blocking-write ; M: fd-stream freadln ( stream -- str ) - [ "in" get dup [ blocking-read-line ] when ] bind ; + fd-stream-in dup [ blocking-read-line ] when ; M: fd-stream fread# ( count stream -- str ) - [ "in" get dup [ blocking-read# ] [ nip ] ifte ] bind ; + fd-stream-in dup [ blocking-read# ] [ nip ] ifte ; M: fd-stream fflush ( stream -- ) - [ "out" get [ blocking-flush ] when* ] bind ; + fd-stream-out [ blocking-flush ] when* ; M: fd-stream fauto-flush ( stream -- ) drop ; -M: fd-stream fclose ( -- ) - [ - "out" get [ dup blocking-flush close-port ] when* - "in" get [ close-port ] when* - ] bind ; +M: fd-stream fclose ( stream -- ) + dup fd-stream-out [ dup blocking-flush close-port ] when* + fd-stream-in [ close-port ] when* ; C: fd-stream ( in out -- stream ) - [ "out" set "in" set ] extend ; + [ set-fd-stream-out ] keep + [ set-fd-stream-in ] keep ; : ( path -- stream ) t f open-file ; @@ -77,7 +45,7 @@ C: fd-stream ( in out -- stream ) #! Copy the contents of the fd-stream 'from' to the #! fd-stream 'to'. Use fcopy; this word does not close #! streams. - "out" swap hash >r "in" swap hash r> blocking-copy ; + fd-stream-out >r fd-stream-in r> blocking-copy ; : fcopy ( from to -- ) #! Copy the contents of the fd-stream 'from' to the diff --git a/library/io/stream.factor b/library/io/stream.factor index c81c430413..834accfbeb 100644 --- a/library/io/stream.factor +++ b/library/io/stream.factor @@ -1,37 +1,9 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2003, 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! Copyright (C) 2003, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: stdio +DEFER: stdio IN: streams -USE: errors -USE: kernel -USE: namespaces -USE: strings -USE: generic -USE: lists +USING: errors kernel namespaces strings generic lists ; GENERIC: fflush ( stream -- ) GENERIC: fauto-flush ( stream -- ) @@ -52,46 +24,32 @@ GENERIC: fclose ( stream -- ) [ "\n" swap fwrite ] keep fauto-flush ; -TRAITS: string-output-stream +! A stream that builds a string of all text written to it. +TUPLE: string-output buf ; -M: string-output-stream fwrite-attr ( string style stream -- ) - [ drop "buf" get sbuf-append ] bind ; +M: string-output fwrite-attr ( string style stream -- ) + nip string-output-buf sbuf-append ; -M: string-output-stream fclose ( stream -- ) - drop ; - -M: string-output-stream fflush ( stream -- ) - drop ; - -M: string-output-stream fauto-flush ( stream -- ) - drop ; +M: string-output fclose ( stream -- ) drop ; +M: string-output fflush ( stream -- ) drop ; +M: string-output fauto-flush ( stream -- ) drop ; : stream>str ( stream -- string ) #! Returns the string written to the given string output #! stream. - [ "buf" get ] bind sbuf>str ; + string-output-buf sbuf>str ; -C: string-output-stream ( size -- stream ) +C: string-output ( size -- stream ) #! Creates a new stream for writing to a string buffer. - [ "buf" set ] extend ; + [ >r r> set-string-output-buf ] keep ; -! Prefix stream prefixes each line with a given string. -TRAITS: prefix-stream -SYMBOL: prefix -SYMBOL: last-newline +! Sometimes, we want to have a delegating stream that uses stdio +! words. +TUPLE: wrapper-stream delegate scope ; -M: prefix-stream fwrite-attr ( string style stream -- ) +C: wrapper-stream ( stream -- stream ) + 2dup set-wrapper-stream-delegate [ - last-newline get [ - prefix get delegate get fwrite last-newline off - ] when - - dupd delegate get fwrite-attr - - "\n" str-tail? [ - last-newline on - ] when - ] bind ; - -C: prefix-stream ( prefix stream -- stream ) - [ last-newline on delegate set prefix set ] extend ; + >r [ stdio set ] extend r> + set-wrapper-stream-scope + ] keep ; diff --git a/library/primitives.factor b/library/primitives.factor index 3a9f4d3b80..ce1c816826 100644 --- a/library/primitives.factor +++ b/library/primitives.factor @@ -185,6 +185,8 @@ hashtables ; [ [ [ number ] [ hashtable ] ] ] [ [ [ number ] [ array ] ] ] [ [ [ number ] [ tuple ] ] ] + [ >array [ [ object ] [ array ] ] ] + [ >tuple [ [ object ] [ tuple ] ] ] ] [ 2unlist dup string? [ "stack-effect" set-word-property diff --git a/library/test/benchmark/strings.factor b/library/test/benchmark/strings.factor index 6308741eae..f9aac6a36c 100644 --- a/library/test/benchmark/strings.factor +++ b/library/test/benchmark/strings.factor @@ -21,4 +21,4 @@ USE: compiler : string-benchmark ( n -- ) "abcdef" 10 [ 2dup string-step ] times 2drop ; compiled -[ ] [ 1000000 string-benchmark ] unit-test +[ ] [ 400000 string-benchmark ] unit-test diff --git a/library/test/generic.factor b/library/test/generic.factor index 7b039e6cd3..ea3d5bd9f6 100644 --- a/library/test/generic.factor +++ b/library/test/generic.factor @@ -10,58 +10,6 @@ USE: lists USE: vectors USE: alien -TRAITS: test-traits -C: test-traits ; - -[ t ] [ test-traits? ] unit-test -[ f ] [ "hello" test-traits? ] unit-test -[ f ] [ test-traits? ] unit-test - -GENERIC: foo - -M: test-traits foo drop 12 ; - -TRAITS: another-test -C: another-test ; - -M: another-test foo drop 13 ; - -[ 12 ] [ foo ] unit-test -[ 13 ] [ foo ] unit-test - -TRAITS: quux -C: quux ; - -M: quux foo "foo" swap hash ; - -[ - "Hi" -] [ - [ - "Hi" "foo" set - ] extend foo -] unit-test - -TRAITS: ctr-test -C: ctr-test [ 5 "x" set ] extend ; - -[ - 5 -] [ - [ "x" get ] bind -] unit-test - -TRAITS: del1 -C: del1 ; - -GENERIC: super -M: del1 super drop 5 ; - -TRAITS: del2 -C: del2 ( delegate -- del2 ) [ delegate set ] extend ; - -[ 5 ] [ super ] unit-test - GENERIC: class-of M: fixnum class-of drop "fixnum" ; @@ -140,8 +88,6 @@ M: very-funny gooey sq ; [ number ] [ number object class-and ] unit-test [ number ] [ object number class-and ] unit-test -[ t ] [ del1 builtin-supertypes [ integer? ] all? ] unit-test - [ cons ] [ [ 1 2 ] class ] unit-test [ t ] [ \ generic \ compound class< ] unit-test diff --git a/library/test/stream.factor b/library/test/stream.factor index e864c6d706..96f57482d1 100644 --- a/library/test/stream.factor +++ b/library/test/stream.factor @@ -7,34 +7,3 @@ USE: generic USE: kernel [ "xyzzy" ] [ [ "xyzzy" write ] with-string ] unit-test - -TRAITS: xyzzy-stream - -M: xyzzy-stream fwrite-attr ( str style stream -- ) - [ - drop "<" delegate get fwrite - delegate get fwrite - ">" delegate get fwrite - ] bind ; - -M: xyzzy-stream fclose ( stream -- ) - drop ; - -M: xyzzy-stream fflush ( stream -- ) - drop ; - -M: xyzzy-stream fauto-flush ( stream -- ) - drop ; - -C: xyzzy-stream ( stream -- stream ) - [ delegate set ] extend ; - -[ - "" -] [ - [ - stdio get [ - "xyzzy" write - ] with-stream - ] with-string -] unit-test diff --git a/library/tools/debugger.factor b/library/tools/debugger.factor index 2218c6d12b..29fe864382 100644 --- a/library/tools/debugger.factor +++ b/library/tools/debugger.factor @@ -157,9 +157,7 @@ M: object error. ( error -- ) : print-error ( error -- ) #! Print the error. [ - "! " [ - in-parser? [ parse-dump ] when error. - ] with-prefix + in-parser? [ parse-dump ] when error. ] [ flush-error-handler ] catch ; diff --git a/library/tools/jedit-wire.factor b/library/tools/jedit-wire.factor index 58daed042b..160dc59553 100644 --- a/library/tools/jedit-wire.factor +++ b/library/tools/jedit-wire.factor @@ -37,6 +37,7 @@ USE: streams USE: strings USE: words USE: generic +USE: listener ! Wire protocol for jEdit to evaluate Factor code. ! Packets are of the form: @@ -46,7 +47,7 @@ USE: generic ! ! jEdit sends a packet with code to eval, it receives the output ! captured with with-string. -USE: listener + : write-packet ( string -- ) dup str-length write-big-endian-32 write flush ; @@ -77,19 +78,22 @@ USE: listener dup str-length write-big-endian-32 write ; -TRAITS: jedit-stream +TUPLE: jedit-stream delegate ; M: jedit-stream freadln ( stream -- str ) + wrapper-stream-scope [ CHAR: r write flush read-big-endian-32 read# ] bind ; M: jedit-stream fwrite-attr ( str style stream -- ) + wrapper-stream-scope [ [ default-style ] unless* jedit-write-attr ] bind ; M: jedit-stream fflush ( stream -- ) + wrapper-stream-scope [ CHAR: f write flush ] bind ; C: jedit-stream ( stream -- stream ) - [ dup delegate set stdio set ] extend ; + [ >r r> set-jedit-stream-delegate ] keep ; : stream-server ( -- ) #! Execute this in the inferior Factor. diff --git a/library/tools/telnetd.factor b/library/tools/telnetd.factor index 95e146993b..b6432640de 100644 --- a/library/tools/telnetd.factor +++ b/library/tools/telnetd.factor @@ -1,47 +1,11 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2003, 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! Copyright (C) 2003, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: telnetd -USE: errors -USE: listener -USE: kernel -USE: logging -USE: namespaces -USE: stdio -USE: streams -USE: threads -USE: parser +USING: errors listener kernel logging namespaces stdio streams +threads parser ; : telnet-client ( socket -- ) - dup [ - "client" set - log-client - listener - ] with-stream ; + dup [ log-client listener ] with-stream ; : telnet-connection ( socket -- ) [ telnet-client ] in-thread drop ; diff --git a/library/ui/console.factor b/library/ui/console.factor index 1b97d2bfaf..526507a0c2 100644 --- a/library/ui/console.factor +++ b/library/ui/console.factor @@ -199,47 +199,37 @@ SYMBOL: redraw-console ! The console stream -! Restoring this continuation returns to the -! top-level console event loop. -SYMBOL: redraw-continuation - ! Restoring this continuation with a string on the stack returns ! to the caller of freadln. SYMBOL: input-continuation -TRAITS: console-stream +TUPLE: console-stream console redraw-continuation ; C: console-stream ( console console-continuation -- stream ) - [ - redraw-continuation set - console set - ] extend ; + [ set-console-stream-redraw-continuation ] keep + [ set-console-stream-console ] keep ; M: console-stream fflush ( stream -- ) fauto-flush ; M: console-stream fauto-flush ( stream -- ) - [ - console get [ redraw-console on ] bind - ] bind ; + console-stream-console [ redraw-console on ] bind ; M: console-stream freadln ( stream -- line ) [ - [ - console get [ input-continuation set ] bind - redraw-continuation get dup [ - call - ] [ - drop f - ] ifte - ] callcc1 - ] bind ; + swap [ + console-stream-console + [ input-continuation set ] bind + ] keep + dup console-stream-redraw-continuation dup [ + call + ] [ + drop f + ] ifte + ] callcc1 nip ; M: console-stream fwrite-attr ( string style stream -- ) - [ - drop - console get [ console-write ] bind - ] bind ; + nip console-stream-console [ console-write ] bind ; M: console-stream fclose ( stream -- ) drop ; @@ -375,7 +365,6 @@ M: alien handle-event ( event -- ? ) check-event [ console-loop ] when ; : console-quit ( -- ) - redraw-continuation off input-continuation get [ f swap call ] when* SDL_Quit ; diff --git a/native/array.c b/native/array.c index d7e7b97510..37029970ba 100644 --- a/native/array.c +++ b/native/array.c @@ -31,6 +31,11 @@ void primitive_array(void) dpush(tag_object(array(ARRAY_TYPE,capacity,F))); } +void primitive_to_array(void) +{ + type_check(ARRAY_TYPE,dpeek()); +} + void primitive_tuple(void) { F_FIXNUM capacity = to_fixnum(dpop()); @@ -40,6 +45,11 @@ void primitive_tuple(void) dpush(tag_object(array(TUPLE_TYPE,capacity,F))); } +void primitive_to_tuple(void) +{ + type_check(TUPLE_TYPE,dpeek()); +} + F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill) { /* later on, do an optimization: if end of array is here, just grow */ diff --git a/native/array.h b/native/array.h index 7f048c0f0f..5f28a97b02 100644 --- a/native/array.h +++ b/native/array.h @@ -13,7 +13,9 @@ INLINE F_ARRAY* untag_array(CELL tagged) F_ARRAY* allot_array(CELL type, CELL capacity); F_ARRAY* array(CELL type, CELL capacity, CELL fill); void primitive_array(void); +void primitive_to_array(void); void primitive_tuple(void); +void primitive_to_tuple(void); F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill); void primitive_grow_array(void); F_ARRAY* shrink_array(F_ARRAY* array, CELL capacity); diff --git a/native/debug.c b/native/debug.c index 1c1b3ebe14..5d4f793d2a 100644 --- a/native/debug.c +++ b/native/debug.c @@ -15,6 +15,9 @@ bool equals(CELL obj1, CELL obj2) CELL assoc(CELL alist, CELL key) { + if(alist == F) + return F; + if(TAG(alist) != CONS_TYPE) { fprintf(stderr,"Not an alist: %ld\n",alist); @@ -36,6 +39,38 @@ CELL assoc(CELL alist, CELL key) } } +CELL hash(CELL hash, CELL key) +{ + if(type_of(hash) != HASHTABLE_TYPE) + { + fprintf(stderr,"Not a hash: %ld\n",hash); + return F; + } + + { + int i; + + CELL array = ((F_HASHTABLE*)UNTAG(hash))->array; + F_ARRAY* a; + + if(type_of(array) != ARRAY_TYPE) + { + fprintf(stderr,"Not an array: %ld\n",hash); + return F; + } + + a = untag_array(array); + + for(i = 0; i < untag_fixnum_fast(a->capacity); i++) + { + CELL value = assoc(get(AREF(a,i)),key); + if(value != F) + return value; + } + + return F; + } +} void print_cons(CELL cons) { fprintf(stderr,"[ "); @@ -59,7 +94,7 @@ void print_cons(CELL cons) void print_word(F_WORD* word) { - CELL name = assoc(word->plist,tag_object(from_c_string("name"))); + CELL name = hash(word->plist,tag_object(from_c_string("name"))); if(type_of(name) == STRING_TYPE) fprintf(stderr,"%s",to_c_string(untag_string(name))); else @@ -83,6 +118,9 @@ void print_obj(CELL obj) { switch(type_of(obj)) { + case FIXNUM_TYPE: + fprintf(stderr,"%d",untag_fixnum_fast(obj)); + break; case CONS_TYPE: print_cons(obj); break; diff --git a/native/primitives.c b/native/primitives.c index 3a426e454c..7a36c0f14c 100644 --- a/native/primitives.c +++ b/native/primitives.c @@ -176,7 +176,9 @@ void* primitives[] = { primitive_grow_array, primitive_hashtable, primitive_array, - primitive_tuple + primitive_tuple, + primitive_to_array, + primitive_to_tuple }; CELL primitive_to_xt(CELL primitive) From c35f6f9f441389df0d99008d861983c7d80658c6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 31 Jan 2005 19:02:09 +0000 Subject: [PATCH 042/122] fixed compiler; UI work --- TODO.FACTOR.txt | 2 + library/bootstrap/boot-stage2.factor | 3 + library/compiler/alien.factor | 8 +-- library/generic/tuple.factor | 24 ++++++++ library/inference/branches.factor | 6 +- library/inference/inference.factor | 26 ++++----- library/inference/types.factor | 4 +- library/inference/words.factor | 21 +------ library/lists.factor | 3 + library/sdl/sdl-utils.factor | 2 +- library/test/test.factor | 1 + library/test/tuple.factor | 18 ++++++ library/ui/gadgets.factor | 82 ++++++++++++++++++++++++++++ library/ui/paint.factor | 35 ++++++++++++ library/ui/shapes.factor | 66 ++++++++++++++++++++++ 15 files changed, 258 insertions(+), 43 deletions(-) create mode 100644 library/test/tuple.factor create mode 100644 library/ui/gadgets.factor create mode 100644 library/ui/paint.factor create mode 100644 library/ui/shapes.factor diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index be31f5fcbd..5d6416341a 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -8,6 +8,7 @@ - goal: to compile hash* optimally - type check/not-check entry points for compiled words - getenv/setenv: if literal arg, compile as a load/store +- empty ifte: wrong input type. + oop: @@ -40,6 +41,7 @@ - completion in the listener - special completion for USE:/IN: - support USING: +- command to prettyprint word def at caret, or selection + i/o: diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index 9e7e0e142b..1267aec8b9 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -108,6 +108,9 @@ USING: kernel lists parser stdio words namespaces ; "/library/ui/line-editor.factor" "/library/ui/console.factor" + "/library/ui/shapes.factor" + "/library/ui/paint.factor" + "/library/ui/gadgets.factor" "/library/bootstrap/image.factor" diff --git a/library/compiler/alien.factor b/library/compiler/alien.factor index 67e42248e7..cc0992d348 100644 --- a/library/compiler/alien.factor +++ b/library/compiler/alien.factor @@ -96,10 +96,10 @@ SYMBOL: alien-parameters : infer-alien ( -- ) [ object object object object ] ensure-d - dataflow-drop, pop-d value-literal - dataflow-drop, pop-d value-literal >r - dataflow-drop, pop-d value-literal - dataflow-drop, pop-d value-literal -rot + dataflow-drop, pop-d literal-value + dataflow-drop, pop-d literal-value >r + dataflow-drop, pop-d literal-value + dataflow-drop, pop-d literal-value -rot r> swap alien-node ; : box-parameter diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor index a47adedad0..5ef4aa927e 100644 --- a/library/generic/tuple.factor +++ b/library/generic/tuple.factor @@ -98,6 +98,30 @@ kernel-internals math hashtables errors ; >r unit [ car tuple-dispatch call ] cons tuple r> set-vtable ; +M: tuple clone ( tuple -- tuple ) + dup array-capacity dup [ -rot copy-array ] keep ; + +: tuple>list ( tuple -- list ) + dup array-capacity swap array>list ; + +M: tuple = ( obj tuple -- ? ) + over tuple? [ + over class over class = [ + swap tuple>list swap tuple>list = + ] [ + 2drop f + ] ifte + ] [ + 2drop f + ] ifte ; + +M: tuple hashcode ( vec -- n ) + dup array-capacity 1 number= [ + drop 0 + ] [ + 1 swap array-nth hashcode + ] ifte ; + M: tuple class ( obj -- class ) 2 slot ; tuple [ diff --git a/library/inference/branches.factor b/library/inference/branches.factor index 2dd5b5b3bb..322ce0e1ee 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -113,7 +113,7 @@ SYMBOL: cloned uncons propagate-type dup value-recursion recursive-state set copy-inference - value-literal dup infer-quot + literal-value dup infer-quot #values values-node handle-terminator ] extend ; @@ -177,7 +177,7 @@ SYMBOL: cloned dataflow-drop, pop-d boolean-value [ drop ] [ nip ] ifte gensym [ dup value-recursion recursive-state set - value-literal infer-quot + literal-value infer-quot ] (with-block) drop ; : dynamic-ifte ( true false -- ) @@ -204,7 +204,7 @@ SYMBOL: cloned \ ifte [ infer-ifte ] "infer" set-word-property : vtable>list ( value -- list ) - dup value-recursion swap value-literal vector>list + dup value-recursion swap literal-value vector>list [ over ] map nip ; USE: kernel-internals diff --git a/library/inference/inference.factor b/library/inference/inference.factor index 4f35dda879..c46c0d2fa4 100644 --- a/library/inference/inference.factor +++ b/library/inference/inference.factor @@ -63,20 +63,16 @@ SYMBOL: recursive-state GENERIC: value= ( literal value -- ? ) GENERIC: value-class-and ( class value -- ) -! A value has the following slots in addition to those relating -! to generics above: +TUPLE: value class type-prop recursion ; -TUPLE: value literal class type-prop recursion ; -C: value ; +C: value ( recursion -- value ) + [ set-value-recursion ] keep ; TUPLE: computed delegate ; C: computed ( class -- value ) - over set-computed-delegate - [ set-value-class ] keep ; - -M: computed value-literal ( value -- obj ) - "Cannot use a computed value literally." throw ; + swap recursive-state get [ set-value-class ] keep + over set-computed-delegate ; M: computed value= ( literal value -- ? ) 2drop f ; @@ -84,15 +80,17 @@ M: computed value= ( literal value -- ? ) M: computed value-class-and ( class value -- ) [ value-class class-and ] keep set-value-class ; -TUPLE: literal delegate ; +TUPLE: literal value delegate ; C: literal ( obj rstate -- value ) - over set-literal-delegate - [ set-value-recursion ] keep - [ set-value-literal ] keep ; + [ + >r [ >r dup class r> set-value-class ] keep + r> set-literal-delegate + ] keep + [ set-literal-value ] keep ; M: literal value= ( literal value -- ? ) - value-literal = ; + literal-value = ; M: literal value-class-and ( class value -- ) value-class class-and drop ; diff --git a/library/inference/types.factor b/library/inference/types.factor index b6a1c377eb..c1d378964a 100644 --- a/library/inference/types.factor +++ b/library/inference/types.factor @@ -29,7 +29,7 @@ lists math namespaces strings vectors words stdio prettyprint ; ! \ slot [ ! [ object fixnum ] ensure-d -! dataflow-drop, pop-d value-literal +! dataflow-drop, pop-d literal-value ! peek-d value-class builtin-supertypes dup length 1 = [ ! cons \ slot [ [ object ] [ object ] ] (consume/produce) ! ] [ @@ -48,7 +48,7 @@ lists math namespaces strings vectors words stdio prettyprint ; 1 0 node-inputs [ object ] consume-d [ fixnum ] produce-d - r> peek-d value-type-prop + r> peek-d set-value-type-prop 1 0 node-outputs ] bind ] "infer" set-word-property diff --git a/library/inference/words.factor b/library/inference/words.factor index 35d55fd2f9..416322e074 100644 --- a/library/inference/words.factor +++ b/library/inference/words.factor @@ -87,23 +87,6 @@ M: promise (apply-word) ( word -- ) M: symbol (apply-word) ( word -- ) apply-literal ; -: current-word ( -- word ) - #! Push word we're currently inferring effect of. - recursive-state get car car ; - -: check-recursion ( word -- ) - #! If at the location of the recursive call, we're taking - #! more items from the stack than producing, we have a - #! diverging recursion. Note that this check is not done for - #! mutually-recursive words. Generally they should be - #! avoided. - current-word = [ - d-in get vector-length - meta-d get vector-length > [ - current-word word-name " diverges." cat2 throw - ] when - ] when ; - : with-recursion ( quot -- ) [ inferring-base-case inc @@ -143,7 +126,7 @@ M: symbol (apply-word) ( word -- ) : apply-word ( word -- ) #! Apply the word's stack effect to the inferencer state. dup recursive-state get assoc [ - dup check-recursion recursive-word + recursive-word ] [ dup "infer-effect" word-property [ apply-effect @@ -158,7 +141,7 @@ M: symbol (apply-word) ( word -- ) gensym dup [ drop pop-d dup value-recursion recursive-state set - value-literal infer-quot + literal-value infer-quot ] with-block drop ; \ call [ infer-call ] "infer" set-word-property diff --git a/library/lists.factor b/library/lists.factor index 8c5fcf1a2c..d93d7f195a 100644 --- a/library/lists.factor +++ b/library/lists.factor @@ -11,6 +11,9 @@ IN: lists USING: generic kernel math ; : 3list ( a b c -- [ a b c ] ) 2list cons ; +: 3unlist ( [ a b c ] -- a b c ) + uncons uncons car ; + : append ( [ list1 ] [ list2 ] -- [ list1 list2 ] ) over [ >r uncons r> append cons ] [ nip ] ifte ; diff --git a/library/sdl/sdl-utils.factor b/library/sdl/sdl-utils.factor index 0f3b252445..9a5234c475 100644 --- a/library/sdl/sdl-utils.factor +++ b/library/sdl/sdl-utils.factor @@ -57,7 +57,7 @@ SYMBOL: surface #! Set up SDL graphics and call the quotation. [ >r init-screen r> call SDL_Quit ] with-scope ; inline -: rgb ( r g b a -- n ) +: rgb ( r g b -- n ) 255 swap 8 shift bitor swap 16 shift bitor diff --git a/library/test/test.factor b/library/test/test.factor index e412cf6d91..f613759779 100644 --- a/library/test/test.factor +++ b/library/test/test.factor @@ -67,6 +67,7 @@ USE: unparser "strings" "namespaces" "generic" + "tuple" "files" "parser" "parse-number" diff --git a/library/test/tuple.factor b/library/test/tuple.factor new file mode 100644 index 0000000000..91a2a2457c --- /dev/null +++ b/library/test/tuple.factor @@ -0,0 +1,18 @@ +IN: scratchpad +USING: generic kernel test math ; + +TUPLE: rect x y w h ; +C: rect + [ set-rect-h ] keep + [ set-rect-w ] keep + [ set-rect-y ] keep + [ set-rect-x ] keep ; + +: move ( x rect -- ) + [ rect-x + ] keep set-rect-x ; + +[ f ] [ 10 20 30 40 dup clone 5 swap [ move ] keep = ] unit-test + +[ t ] [ 10 20 30 40 dup clone 0 swap [ move ] keep = ] unit-test + + diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor new file mode 100644 index 0000000000..9206e0d804 --- /dev/null +++ b/library/ui/gadgets.factor @@ -0,0 +1,82 @@ +! Copyright (C) 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: gadgets +USING: generic hashtables kernel lists namespaces ; + +! Gadget protocol. +GENERIC: pick-up ( point gadget -- gadget ) + +! A gadget is a shape together with paint, and a reference to +! the gadget's parent. A gadget delegates to its shape. +TUPLE: gadget paint parent delegate ; + +C: gadget ( shape -- gadget ) + [ set-gadget-delegate ] keep + [ swap set-gadget-paint ] keep ; + +: paint-property ( gadget key -- value ) + swap gadget-paint hash ; + +: set-paint-property ( gadget value key -- ) + rot gadget-paint set-hash ; + +: with-gadget ( gadget quot -- ) + #! All drawing done inside the quotation is done with the + #! gadget's paint. If the gadget does not have any custom + #! paint, just call the quotation. + >r gadget-paint r> bind ; + +M: gadget draw ( gadget -- ) + dup [ gadget-delegate draw ] with-gadget ; + +M: gadget pick-up tuck inside? [ drop f ] unless ; + +! An invisible gadget. +WRAPPER: ghost +M: ghost draw drop ; +M: ghost pick-up 2drop f ; + +! A box is a gadget holding other gadgets. +TUPLE: box contents delegate ; + +C: box ( gadget -- box ) + [ set-box-delegate ] keep ; + +M: general-list draw ( list -- ) + [ draw ] each ; + +M: box draw ( box -- ) + dup [ + dup [ + dup box-contents draw + box-delegate draw + ] with-gadget + ] with-translation ; + +M: general-list pick-up ( point list -- gadget ) + dup [ + 2dup car pick-up dup [ + 2nip + ] [ + drop cdr pick-up + ] ifte + ] [ + 2drop f + ] ifte ; + +M: box pick-up ( point box -- ) + #! The logic is thus. If the point is definately outside the + #! box, return f. Otherwise, see if the point is contained + #! in any subgadget. If not, see if it is contained in the + #! box delegate. + dup [ + 2dup gadget-delegate inside? [ + 2dup box-contents pick-up dup [ + 2nip + ] [ + drop box-delegate pick-up + ] ifte + ] [ + 2drop f + ] ifte + ] with-translation ; diff --git a/library/ui/paint.factor b/library/ui/paint.factor new file mode 100644 index 0000000000..6e08f10349 --- /dev/null +++ b/library/ui/paint.factor @@ -0,0 +1,35 @@ +! Copyright (C) 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: gadgets +USING: generic kernel lists math namespaces sdl sdl-gfx ; + +! The painting protocol. Painting is controlled by various +! dynamically-scoped variables. + +! "Paint" is a namespace containing some or all of these values. +SYMBOL: color ! a list of three integers, 0..255. +SYMBOL: font ! a list of two elements, a font name and size. +SYMBOL: filled ! is the interior of the shape filled? + +: shape>screen ( shape -- x1 y1 x2 y2 ) + [ shape-x x get + ] keep + [ shape-y y get + ] keep + [ dup shape-x swap shape-w + x get + ] keep + dup shape-y swap shape-h + y get + ; + +: rgb-color ( -- rgba ) color get 3unlist rgb ; + +GENERIC: draw ( obj -- ) + +M: rect draw ( rect -- ) + >r surface get r> shape>screen rgb-color + filled get [ boxColor ] [ rectangleColor ] ifte ; + +: default-paint ( -- paint ) + {{ + [[ x 0 ]] + [[ y 0 ]] + [[ color [ 0 0 0 ] ]] + [[ filled f ]] + [[ font [ "Monospaced" 12 ] ]] + }} ; diff --git a/library/ui/shapes.factor b/library/ui/shapes.factor new file mode 100644 index 0000000000..0ff0cc5dca --- /dev/null +++ b/library/ui/shapes.factor @@ -0,0 +1,66 @@ +! Copyright (C) 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: gadgets +USING: generic kernel math namespaces ; + +! Shape protocol. + +! These dynamically-bound variables affect the generic word +! inside?. +SYMBOL: x ! x translation +SYMBOL: y ! y translation + +! A shape is an object with a defined bounding +! box, and a notion of interior. +GENERIC: shape-x +GENERIC: shape-y +GENERIC: shape-w +GENERIC: shape-h + +GENERIC: inside? ( point shape -- ? ) + +: with-translation ( shape quot -- ) + #! All drawing done inside the quotation is translated + #! relative to the shape's origin. + [ + >r dup + shape-x x [ + ] change + shape-y y [ + ] change + r> call + ] with-scope ; inline + +! A point, represented as a complex number, is the simplest type +! of shape. +M: number shape-x real ; +M: number shape-y imaginary ; +M: number shape-w drop 0 ; +M: number shape-h drop 0 ; +M: number inside? = ; + +! A rectangle maps trivially to the shape protocol. +TUPLE: rect x y w h ; +M: rect shape-x rect-x ; +M: rect shape-y rect-y ; +M: rect shape-w rect-w ; +M: rect shape-h rect-h ; + +: fix-neg ( a b c -- a+c b -c ) + dup 0 < [ neg tuck >r >r + r> r> ] when ; + +C: rect ( x y w h -- rect ) + #! We handle negative w/h for convinience. + >r fix-neg >r fix-neg r> r> + [ set-rect-h ] keep + [ set-rect-w ] keep + [ set-rect-y ] keep + [ set-rect-x ] keep ; + +: rect-x-extents ( rect -- x1 x2 ) + dup rect-x x get + swap rect-w dupd + ; + +: rect-y-extents ( rect -- x1 x2 ) + dup rect-y y get + swap rect-h dupd + ; + +M: rect inside? ( point rect -- ? ) + over real over rect-x-extents between? >r + swap imaginary swap rect-y-extents between? r> and ; From 8a42466cf2c326c467dba2945068646090211141 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 1 Feb 2005 03:32:06 +0000 Subject: [PATCH 043/122] more UI work --- TODO.FACTOR.txt | 1 + factor/DefaultVocabularyLookup.java | 4 +- factor/parser/Tuple.java | 69 ++++++++++++++++++++++++++++ library/bootstrap/boot-stage2.factor | 15 +++--- library/generic/tuple.factor | 21 +++++---- library/test/gadgets.factor | 61 ++++++++++++++++++++++++ library/test/test.factor | 1 + library/ui/boxes.factor | 58 +++++++++++++++++++++++ library/ui/gadgets.factor | 48 ++----------------- library/ui/gestures.factor | 18 ++++++++ library/ui/shapes.factor | 4 +- library/ui/world.factor | 69 ++++++++++++++++++++++++++++ 12 files changed, 306 insertions(+), 63 deletions(-) create mode 100644 factor/parser/Tuple.java create mode 100644 library/test/gadgets.factor create mode 100644 library/ui/boxes.factor create mode 100644 library/ui/gestures.factor create mode 100644 library/ui/world.factor diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 5d6416341a..385fa2a008 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -15,6 +15,7 @@ - make see work with union, builtin, predicate - doc comments of generics - proper ordering for classes +- tuples: in/out syntax + ffi: diff --git a/factor/DefaultVocabularyLookup.java b/factor/DefaultVocabularyLookup.java index fd18adb2e9..3561609c92 100644 --- a/factor/DefaultVocabularyLookup.java +++ b/factor/DefaultVocabularyLookup.java @@ -3,7 +3,7 @@ /* * $Id$ * - * Copyright (C) 2004 Slava Pestov. + * Copyright (C) 2004, 2005 Slava Pestov. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are met: @@ -133,6 +133,8 @@ public class DefaultVocabularyLookup implements VocabularyLookup beginPredicate.parsing = new BeginPredicate(beginPredicate); FactorWord beginUnion = define("generic","UNION:"); beginUnion.parsing = new BeginUnion(beginUnion); + FactorWord tuple = define("generic","TUPLE:"); + tuple.parsing = new Tuple(tuple); } //}}} //{{{ getVocabulary() method diff --git a/factor/parser/Tuple.java b/factor/parser/Tuple.java new file mode 100644 index 0000000000..a8e5fac8a5 --- /dev/null +++ b/factor/parser/Tuple.java @@ -0,0 +1,69 @@ +/* :folding=explicit:collapseFolds=1: */ + +/* + * $Id$ + * + * Copyright (C) 2005 Slava Pestov. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * 1. Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND + * FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; + * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, + * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR + * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF + * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + */ + +package factor.parser; + +import factor.*; + +public class Tuple extends FactorParsingDefinition +{ + public Tuple(FactorWord word) + { + super(word); + } + + public void eval(FactorReader reader) + throws Exception + { + Object next = reader.nextNonEOL(false,false); + if(!(next instanceof String)) + { + reader.getScanner().error("Missing tuple name"); + return; + } + + String tupleName = (String)next; + reader.intern(tupleName,true); + reader.intern("<" + tupleName + ">",true); + + for(;;) + { + next = reader.next(false,false); + if(next == FactorScanner.EOF) + reader.getScanner().error("Expected ;"); + if(next.equals(";")) + break; + else if(next instanceof String) + { + reader.intern(tupleName + "-" + next,true); + reader.intern("set-" + tupleName + "-" + next,true); + } + } + } +} diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index 1267aec8b9..e75e4fc963 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -106,12 +106,6 @@ USING: kernel lists parser stdio words namespaces ; "/library/sdl/sdl-utils.factor" "/library/sdl/hsv.factor" - "/library/ui/line-editor.factor" - "/library/ui/console.factor" - "/library/ui/shapes.factor" - "/library/ui/paint.factor" - "/library/ui/gadgets.factor" - "/library/bootstrap/image.factor" "/library/httpd/url-encoding.factor" @@ -155,6 +149,15 @@ cpu "x86" = [ "/library/compiler/x86/stack.factor" "/library/compiler/x86/generator.factor" "/library/compiler/x86/fixnum.factor" + + "/library/ui/line-editor.factor" + "/library/ui/console.factor" + "/library/ui/shapes.factor" + "/library/ui/paint.factor" + "/library/ui/gadgets.factor" + "/library/ui/boxes.factor" + "/library/ui/gestures.factor" + "/library/ui/world.factor" ] [ dup print run-resource diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor index 5ef4aa927e..a6f4ddecd6 100644 --- a/library/generic/tuple.factor +++ b/library/generic/tuple.factor @@ -77,26 +77,29 @@ kernel-internals math hashtables errors ; scan-word [ tuple-constructor ] f ; parsing : tuple-delegate ( tuple -- obj ) - >tuple dup class "delegate-field" word-property dup [ - >fixnum slot + dup tuple? [ + dup class "delegate-field" word-property dup [ + >fixnum slot + ] [ + 2drop f + ] ifte ] [ - 2drop f + drop f ] ifte ; inline -: tuple-dispatch ( object selector -- object quot ) +: tuple-dispatch ( object selector -- ) over class over "methods" word-property hash* [ - cdr ( method is defined ) + cdr call ( method is defined ) ] [ over tuple-delegate [ - rot drop swap tuple-dispatch ( check delegate ) + rot drop swap execute ( check delegate ) ] [ - [ undefined-method ] ( no delegate ) + undefined-method ( no delegate ) ] ifte* ] ?ifte ; : add-tuple-dispatch ( word vtable -- ) - >r unit [ car tuple-dispatch call ] cons tuple r> - set-vtable ; + >r unit [ car tuple-dispatch ] cons tuple r> set-vtable ; M: tuple clone ( tuple -- tuple ) dup array-capacity dup [ -rot copy-array ] keep ; diff --git a/library/test/gadgets.factor b/library/test/gadgets.factor new file mode 100644 index 0000000000..322eba4137 --- /dev/null +++ b/library/test/gadgets.factor @@ -0,0 +1,61 @@ +IN: scratchpad +USING: gadgets kernel lists math namespaces test ; + +[ t ] [ + [ + 2000 x set + 2000 y set + 2030 2040 rect> 10 20 300 400 inside? + ] with-scope +] unit-test +[ f ] [ + [ + 2000 x set + 2000 y set + 2500 2040 rect> 10 20 300 400 inside? + ] with-scope +] unit-test +[ t ] [ + [ + -10 x set + -20 y set + 0 0 rect> 10 20 300 400 inside? + ] with-scope +] unit-test +[ 11 11 41 41 ] [ + default-paint [ + [ + 1 x set + 1 y set + 10 10 30 30 shape>screen + ] with-scope + ] bind +] unit-test +[ t ] [ + default-paint [ + 0 0 rect> -10 -10 20 20 [ pick-up ] keep = + ] bind +] unit-test + +: funny-rect ( x -- rect ) + 10 10 30 + dup [ 255 0 0 ] color set-paint-property + dup t filled set-paint-property ; + +[ f ] [ + default-paint [ + 35 0 rect> + [ 10 30 50 70 ] [ funny-rect ] map + pick-up + ] bind +] unit-test + +[ 30 ] [ + default-paint [ + 35 10 rect> + [ 10 30 50 70 ] [ funny-rect ] map + 0 0 200 200 + [ set-box-contents ] keep + pick-up shape-x + ] bind +] unit-test diff --git a/library/test/test.factor b/library/test/test.factor index f613759779..9eaa372868 100644 --- a/library/test/test.factor +++ b/library/test/test.factor @@ -103,6 +103,7 @@ USE: unparser "hsv" "alien" "line-editor" + "gadgets" ] [ test ] each diff --git a/library/ui/boxes.factor b/library/ui/boxes.factor new file mode 100644 index 0000000000..bd75533982 --- /dev/null +++ b/library/ui/boxes.factor @@ -0,0 +1,58 @@ +! Copyright (C) 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: gadgets +USING: generic hashtables kernel lists namespaces ; + +! A box is a gadget holding other gadgets. +TUPLE: box contents delegate ; + +C: box ( gadget -- box ) + [ set-box-delegate ] keep ; + +M: general-list draw ( list -- ) + [ draw ] each ; + +M: box draw ( box -- ) + dup [ + dup [ + dup box-contents draw + box-delegate draw + ] with-gadget + ] with-translation ; + +M: general-list pick-up ( point list -- gadget ) + dup [ + 2dup car pick-up dup [ + 2nip + ] [ + drop cdr pick-up + ] ifte + ] [ + 2drop f + ] ifte ; + +M: box pick-up ( point box -- gadget ) + #! The logic is thus. If the point is definately outside the + #! box, return f. Otherwise, see if the point is contained + #! in any subgadget. If not, see if it is contained in the + #! box delegate. + dup [ + 2dup gadget-delegate inside? [ + 2dup box-contents pick-up dup [ + 2nip + ] [ + drop box-delegate pick-up + ] ifte + ] [ + 2drop f + ] ifte + ] with-translation ; + +: box- ( gadget box -- ) + 2dup box-contents remove swap set-box-contents + f swap set-gadget-parent ; + +: box+ ( gadget box -- ) + #! Add a gadget to a box. + swap dup gadget-parent dup [ box- ] [ 2drop ] ifte + [ box-contents cons ] keep set-box-contents ; diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index 9206e0d804..78fbf32333 100644 --- a/library/ui/gadgets.factor +++ b/library/ui/gadgets.factor @@ -5,6 +5,7 @@ USING: generic hashtables kernel lists namespaces ; ! Gadget protocol. GENERIC: pick-up ( point gadget -- gadget ) +GENERIC: handle-gesture* ( gesture gadget -- ? ) ! A gadget is a shape together with paint, and a reference to ! the gadget's parent. A gadget delegates to its shape. @@ -31,52 +32,9 @@ M: gadget draw ( gadget -- ) M: gadget pick-up tuck inside? [ drop f ] unless ; +M: gadget handle-gesture* 2drop t ; + ! An invisible gadget. WRAPPER: ghost M: ghost draw drop ; M: ghost pick-up 2drop f ; - -! A box is a gadget holding other gadgets. -TUPLE: box contents delegate ; - -C: box ( gadget -- box ) - [ set-box-delegate ] keep ; - -M: general-list draw ( list -- ) - [ draw ] each ; - -M: box draw ( box -- ) - dup [ - dup [ - dup box-contents draw - box-delegate draw - ] with-gadget - ] with-translation ; - -M: general-list pick-up ( point list -- gadget ) - dup [ - 2dup car pick-up dup [ - 2nip - ] [ - drop cdr pick-up - ] ifte - ] [ - 2drop f - ] ifte ; - -M: box pick-up ( point box -- ) - #! The logic is thus. If the point is definately outside the - #! box, return f. Otherwise, see if the point is contained - #! in any subgadget. If not, see if it is contained in the - #! box delegate. - dup [ - 2dup gadget-delegate inside? [ - 2dup box-contents pick-up dup [ - 2nip - ] [ - drop box-delegate pick-up - ] ifte - ] [ - 2drop f - ] ifte - ] with-translation ; diff --git a/library/ui/gestures.factor b/library/ui/gestures.factor new file mode 100644 index 0000000000..0840ec0eeb --- /dev/null +++ b/library/ui/gestures.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: gadgets +USING: generic kernel lists sdl-event ; + +: handle-gesture ( gesture gadget -- ) + #! If a gadget's handle-gesture* generic returns t, the + #! event was not consumed and is passed on to the gadget's + #! parent. + 2dup handle-gesture* [ + gadget-parent dup [ + handle-gesture + ] [ + 2drop + ] ifte + ] [ + 2drop + ] ifte ; diff --git a/library/ui/shapes.factor b/library/ui/shapes.factor index 0ff0cc5dca..10de50cb36 100644 --- a/library/ui/shapes.factor +++ b/library/ui/shapes.factor @@ -62,5 +62,5 @@ C: rect ( x y w h -- rect ) dup rect-y y get + swap rect-h dupd + ; M: rect inside? ( point rect -- ? ) - over real over rect-x-extents between? >r - swap imaginary swap rect-y-extents between? r> and ; + over shape-x over rect-x-extents between? >r + swap shape-y swap rect-y-extents between? r> and ; diff --git a/library/ui/world.factor b/library/ui/world.factor new file mode 100644 index 0000000000..114f0868e9 --- /dev/null +++ b/library/ui/world.factor @@ -0,0 +1,69 @@ +! Copyright (C) 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: gadgets +USING: alien generic kernel lists math namespaces sdl sdl-event ; + +! The hand is a special gadget that holds mouse position and +! mouse button click state. +TUPLE: hand clicked buttons delegate ; + +C: hand ( -- hand ) 0 over set-hand-delegate ; + +GENERIC: hand-gesture ( hand gesture -- ) + +M: alien hand-gesture ( hand gesture -- ) 2drop ; + +: button/ ( n hand -- ) + [ hand-buttons unique ] keep set-hand-buttons ; + +: button\ ( n hand -- ) + [ hand-buttons remove ] keep set-hand-buttons ; + +M: button-down-event hand-gesture ( hand gesture -- ) + 2dup + dup button-event-x swap button-event-y rect> + swap set-hand-clicked + button-event-button swap button/ ; + +M: button-up-event hand-gesture ( hand gesture -- ) + button-event-button swap button\ ; + +! The world gadget is the top level gadget that all (visible) +! gadgets are contained in. The current world is stored in the +! world variable. +TUPLE: world running? hand delegate ; + +M: hand handle-gesture* ( gesture hand -- ? ) + 2dup swap hand-gesture + world get pick-up handle-gesture* ; + +: ( -- box ) + 0 0 1000 1000 ; + +C: world ( -- world ) + over set-world-delegate + t over set-world-running? + over set-world-hand ; + +GENERIC: world-gesture ( world gesture -- ) + +M: alien world-gesture ( world gesture -- ) 2drop ; + +M: quit-event world-gesture ( world gesture -- ) + drop f swap set-world-running? ; + +M: world handle-gesture* ( gesture world -- ? ) + swap world-gesture f ; + +: my-hand ( -- hand ) world get world-hand ; + +: run-world ( -- ) + world get world-running? [ + dup SDL_WaitEvent 1 = [ + my-hand handle-gesture run-world + ] [ + drop + ] ifte + ] when ; + +global [ world set ] bind From 3453ac0e045ce587caca621e2288f05a698b9aa8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 2 Feb 2005 00:00:16 +0000 Subject: [PATCH 044/122] more UI work --- library/generic/tuple.factor | 17 ++++++++++++----- library/stack.factor | 1 + library/test/tuple.factor | 7 +++++++ library/ui/boxes.factor | 10 +++++----- library/ui/gadgets.factor | 15 ++++++++++++--- library/ui/gestures.factor | 6 +++--- library/ui/shapes.factor | 26 +++++++++++++++++++++----- library/ui/world.factor | 27 +++++++++++++++++++++++++-- 8 files changed, 86 insertions(+), 23 deletions(-) diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor index a6f4ddecd6..c56083970a 100644 --- a/library/generic/tuple.factor +++ b/library/generic/tuple.factor @@ -87,15 +87,22 @@ kernel-internals math hashtables errors ; drop f ] ifte ; inline +: lookup-method ( class selector -- method ) + "methods" word-property hash* ; inline + : tuple-dispatch ( object selector -- ) - over class over "methods" word-property hash* [ + over class over lookup-method [ cdr call ( method is defined ) ] [ - over tuple-delegate [ - rot drop swap execute ( check delegate ) + object over lookup-method [ + cdr call ] [ - undefined-method ( no delegate ) - ] ifte* + over tuple-delegate [ + rot drop swap execute ( check delegate ) + ] [ + undefined-method ( no delegate ) + ] ifte* + ] ?ifte ] ?ifte ; : add-tuple-dispatch ( word vtable -- ) diff --git a/library/stack.factor b/library/stack.factor index 4ff59bc860..deff179ff3 100644 --- a/library/stack.factor +++ b/library/stack.factor @@ -10,6 +10,7 @@ IN: kernel : -rot ( x y z -- z x y ) swap >r swap r> ; inline : dupd ( x y -- x x y ) >r dup r> ; inline : swapd ( x y z -- y x z ) >r swap r> ; inline +: 2swap ( x y z t -- z t x y ) >r rot r> rot ; inline : nip ( x y -- y ) swap drop ; inline : 2nip ( x y z -- z ) >r drop drop r> ; inline : tuck ( x y -- y x y ) dup >r swap r> ; inline diff --git a/library/test/tuple.factor b/library/test/tuple.factor index 91a2a2457c..6dc28a26dd 100644 --- a/library/test/tuple.factor +++ b/library/test/tuple.factor @@ -15,4 +15,11 @@ C: rect [ t ] [ 10 20 30 40 dup clone 0 swap [ move ] keep = ] unit-test +GENERIC: delegation-test +M: object delegation-test drop 3 ; +TUPLE: quux-tuple ; +C: quux-tuple ; +M: quux-tuple delegation-test drop 4 ; +WRAPPER: quuux-tuple +[ 3 ] [ delegation-test ] unit-test diff --git a/library/ui/boxes.factor b/library/ui/boxes.factor index bd75533982..a8ccf80cca 100644 --- a/library/ui/boxes.factor +++ b/library/ui/boxes.factor @@ -20,7 +20,7 @@ M: box draw ( box -- ) ] with-gadget ] with-translation ; -M: general-list pick-up ( point list -- gadget ) +M: general-list pick-up* ( point list -- gadget ) dup [ 2dup car pick-up dup [ 2nip @@ -31,17 +31,17 @@ M: general-list pick-up ( point list -- gadget ) 2drop f ] ifte ; -M: box pick-up ( point box -- gadget ) +M: box pick-up* ( point box -- gadget ) #! The logic is thus. If the point is definately outside the #! box, return f. Otherwise, see if the point is contained #! in any subgadget. If not, see if it is contained in the #! box delegate. dup [ - 2dup gadget-delegate inside? [ + 2dup inside? [ 2dup box-contents pick-up dup [ 2nip ] [ - drop box-delegate pick-up + drop box-delegate pick-up* ] ifte ] [ 2drop f @@ -54,5 +54,5 @@ M: box pick-up ( point box -- gadget ) : box+ ( gadget box -- ) #! Add a gadget to a box. - swap dup gadget-parent dup [ box- ] [ 2drop ] ifte + over gadget-parent [ pick swap box- ] when* [ box-contents cons ] keep set-box-contents ; diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index 78fbf32333..966105cdc4 100644 --- a/library/ui/gadgets.factor +++ b/library/ui/gadgets.factor @@ -4,9 +4,15 @@ IN: gadgets USING: generic hashtables kernel lists namespaces ; ! Gadget protocol. -GENERIC: pick-up ( point gadget -- gadget ) + +GENERIC: pick-up* ( point gadget -- gadget/t ) GENERIC: handle-gesture* ( gesture gadget -- ? ) +: pick-up ( point gadget -- gadget ) + #! pick-up* returns t to mean 'this gadget', avoiding the + #! exposed facade issue. + tuck pick-up* dup t = [ drop ] [ nip ] ifte ; + ! A gadget is a shape together with paint, and a reference to ! the gadget's parent. A gadget delegates to its shape. TUPLE: gadget paint parent delegate ; @@ -30,11 +36,14 @@ C: gadget ( shape -- gadget ) M: gadget draw ( gadget -- ) dup [ gadget-delegate draw ] with-gadget ; -M: gadget pick-up tuck inside? [ drop f ] unless ; +M: gadget pick-up* inside? ; M: gadget handle-gesture* 2drop t ; +: move-gadget ( x y gadget -- ) + [ move-shape ] keep set-gadget-delegate ; + ! An invisible gadget. WRAPPER: ghost M: ghost draw drop ; -M: ghost pick-up 2drop f ; +M: ghost pick-up* 2drop f ; diff --git a/library/ui/gestures.factor b/library/ui/gestures.factor index 0840ec0eeb..0d6c4e8bd5 100644 --- a/library/ui/gestures.factor +++ b/library/ui/gestures.factor @@ -7,9 +7,9 @@ USING: generic kernel lists sdl-event ; #! If a gadget's handle-gesture* generic returns t, the #! event was not consumed and is passed on to the gadget's #! parent. - 2dup handle-gesture* [ - gadget-parent dup [ - handle-gesture + dup [ + 2dup handle-gesture* [ + gadget-parent handle-gesture ] [ 2drop ] ifte diff --git a/library/ui/shapes.factor b/library/ui/shapes.factor index 10de50cb36..6c015c12e7 100644 --- a/library/ui/shapes.factor +++ b/library/ui/shapes.factor @@ -3,12 +3,15 @@ IN: gadgets USING: generic kernel math namespaces ; -! Shape protocol. +! Shape protocol. Shapes are immutable; moving or resizing a +! shape makes a new shape. ! These dynamically-bound variables affect the generic word ! inside?. -SYMBOL: x ! x translation -SYMBOL: y ! y translation +SYMBOL: x +SYMBOL: y + +GENERIC: inside? ( point shape -- ? ) ! A shape is an object with a defined bounding ! box, and a notion of interior. @@ -17,7 +20,8 @@ GENERIC: shape-y GENERIC: shape-w GENERIC: shape-h -GENERIC: inside? ( point shape -- ? ) +GENERIC: move-shape ( x y shape -- shape ) +GENERIC: resize-shape ( w h shape -- shape ) : with-translation ( shape quot -- ) #! All drawing done inside the quotation is translated @@ -31,11 +35,14 @@ GENERIC: inside? ( point shape -- ? ) ! A point, represented as a complex number, is the simplest type ! of shape. +M: number inside? = ; + M: number shape-x real ; M: number shape-y imaginary ; M: number shape-w drop 0 ; M: number shape-h drop 0 ; -M: number inside? = ; + +M: number move-shape ( x y point -- point ) drop rect> ; ! A rectangle maps trivially to the shape protocol. TUPLE: rect x y w h ; @@ -55,6 +62,15 @@ C: rect ( x y w h -- rect ) [ set-rect-y ] keep [ set-rect-x ] keep ; +M: number resize-shape ( w h point -- rect ) + >rect 2swap ; + +M: rect move-shape ( x y rect -- rect ) + [ rect-w ] keep rect-h ; + +M: rect resize-shape ( w h rect -- rect ) + [ rect-x ] keep rect-y 2swap ; + : rect-x-extents ( rect -- x1 x2 ) dup rect-x x get + swap rect-w dupd + ; diff --git a/library/ui/world.factor b/library/ui/world.factor index 114f0868e9..740a0f915c 100644 --- a/library/ui/world.factor +++ b/library/ui/world.factor @@ -28,10 +28,19 @@ M: button-down-event hand-gesture ( hand gesture -- ) M: button-up-event hand-gesture ( hand gesture -- ) button-event-button swap button\ ; +M: motion-event hand-gesture ( hand gesture -- ) + dup motion-event-x swap motion-event-y rot move-gadget ; + ! The world gadget is the top level gadget that all (visible) ! gadgets are contained in. The current world is stored in the ! world variable. -TUPLE: world running? hand delegate ; +TUPLE: world running? hand delegate redraw? ; + +TUPLE: redraw-gesture ; +C: redraw-gesture ; + +: redraw ( gadget -- ) + swap handle-gesture ; M: hand handle-gesture* ( gesture hand -- ? ) 2dup swap hand-gesture @@ -43,6 +52,7 @@ M: hand handle-gesture* ( gesture hand -- ? ) C: world ( -- world ) over set-world-delegate t over set-world-running? + t over set-world-redraw? over set-world-hand ; GENERIC: world-gesture ( world gesture -- ) @@ -52,15 +62,28 @@ M: alien world-gesture ( world gesture -- ) 2drop ; M: quit-event world-gesture ( world gesture -- ) drop f swap set-world-running? ; +M: redraw-gesture world-gesture ( world gesture -- ) + drop t swap set-world-redraw? ; + M: world handle-gesture* ( gesture world -- ? ) swap world-gesture f ; : my-hand ( -- hand ) world get world-hand ; +: draw-world ( -- ) + world get dup world-redraw? [ + [ + f over set-world-redraw? + draw + ] with-surface + ] [ + drop + ] ifte ; + : run-world ( -- ) world get world-running? [ dup SDL_WaitEvent 1 = [ - my-hand handle-gesture run-world + my-hand handle-gesture draw-world run-world ] [ drop ] ifte From cd286eeff72d8a3266f176e11b8242cace8c5786 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 2 Feb 2005 01:14:03 +0000 Subject: [PATCH 045/122] working on hand gadget --- library/bootstrap/boot-stage2.factor | 1 + library/sdl/sdl-utils.factor | 1 + library/stack.factor | 2 +- library/ui/boxes.factor | 17 ++++++-- library/ui/gadgets.factor | 12 ++++- library/ui/gestures.factor | 6 +++ library/ui/hand.factor | 40 +++++++++++++++++ library/ui/paint.factor | 8 +++- library/ui/shapes.factor | 54 +++++++++++++---------- library/ui/world.factor | 65 ++++++++++++---------------- 10 files changed, 139 insertions(+), 67 deletions(-) create mode 100644 library/ui/hand.factor diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index e75e4fc963..d88965f0c2 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -157,6 +157,7 @@ cpu "x86" = [ "/library/ui/gadgets.factor" "/library/ui/boxes.factor" "/library/ui/gestures.factor" + "/library/ui/hand.factor" "/library/ui/world.factor" ] [ dup print diff --git a/library/sdl/sdl-utils.factor b/library/sdl/sdl-utils.factor index 9a5234c475..efba5137a9 100644 --- a/library/sdl/sdl-utils.factor +++ b/library/sdl/sdl-utils.factor @@ -55,6 +55,7 @@ SYMBOL: surface : with-screen ( width height bpp flags quot -- ) #! Set up SDL graphics and call the quotation. + SDL_INIT_EVERYTHING SDL_Init drop TTF_Init [ >r init-screen r> call SDL_Quit ] with-scope ; inline : rgb ( r g b -- n ) diff --git a/library/stack.factor b/library/stack.factor index deff179ff3..2894406aaa 100644 --- a/library/stack.factor +++ b/library/stack.factor @@ -10,7 +10,7 @@ IN: kernel : -rot ( x y z -- z x y ) swap >r swap r> ; inline : dupd ( x y -- x x y ) >r dup r> ; inline : swapd ( x y z -- y x z ) >r swap r> ; inline -: 2swap ( x y z t -- z t x y ) >r rot r> rot ; inline +: 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline : nip ( x y -- y ) swap drop ; inline : 2nip ( x y z -- z ) >r drop drop r> ; inline : tuck ( x y -- y x y ) dup >r swap r> ; inline diff --git a/library/ui/boxes.factor b/library/ui/boxes.factor index a8ccf80cca..37668b581f 100644 --- a/library/ui/boxes.factor +++ b/library/ui/boxes.factor @@ -15,8 +15,9 @@ M: general-list draw ( list -- ) M: box draw ( box -- ) dup [ dup [ - dup box-contents draw + dup box-delegate draw + box-contents draw ] with-gadget ] with-translation ; @@ -49,10 +50,18 @@ M: box pick-up* ( point box -- gadget ) ] with-translation ; : box- ( gadget box -- ) - 2dup box-contents remove swap set-box-contents + 2dup box-contents remove swap tuck set-box-contents redraw f swap set-gadget-parent ; +: (box+) ( gadget box -- ) + [ box-contents cons ] keep set-box-contents ; + +: unparent ( gadget -- ) + dup gadget-parent dup [ box- ] [ 2drop ] ifte ; + : box+ ( gadget box -- ) #! Add a gadget to a box. - over gadget-parent [ pick swap box- ] when* - [ box-contents cons ] keep set-box-contents ; + over unparent + dup pick set-gadget-parent + tuck (box+) + redraw ; diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index 966105cdc4..149245999e 100644 --- a/library/ui/gadgets.factor +++ b/library/ui/gadgets.factor @@ -4,7 +4,6 @@ IN: gadgets USING: generic hashtables kernel lists namespaces ; ! Gadget protocol. - GENERIC: pick-up* ( point gadget -- gadget/t ) GENERIC: handle-gesture* ( gesture gadget -- ? ) @@ -40,8 +39,17 @@ M: gadget pick-up* inside? ; M: gadget handle-gesture* 2drop t ; +GENERIC: redraw ( gadget -- ) + : move-gadget ( x y gadget -- ) - [ move-shape ] keep set-gadget-delegate ; + [ move-shape ] keep + [ set-gadget-delegate ] keep + redraw ; + +: resize-gadget ( w h gadget -- ) + [ resize-shape ] keep + [ set-gadget-delegate ] keep + redraw ; ! An invisible gadget. WRAPPER: ghost diff --git a/library/ui/gestures.factor b/library/ui/gestures.factor index 0d6c4e8bd5..058eee2e39 100644 --- a/library/ui/gestures.factor +++ b/library/ui/gestures.factor @@ -16,3 +16,9 @@ USING: generic kernel lists sdl-event ; ] [ 2drop ] ifte ; + +TUPLE: redraw-gesture ; +C: redraw-gesture ; + +M: object redraw ( gadget -- ) + swap handle-gesture ; diff --git a/library/ui/hand.factor b/library/ui/hand.factor new file mode 100644 index 0000000000..8868b5d743 --- /dev/null +++ b/library/ui/hand.factor @@ -0,0 +1,40 @@ +! Copyright (C) 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: gadgets +USING: alien generic kernel lists math namespaces sdl sdl-event +sdl-video ; + +! The hand is a special gadget that holds mouse position and +! mouse button click state. The hand's parent is the world, but +! it is special in that the world does not list it as part of +! its contents. +TUPLE: hand click-pos clicked buttons delegate ; + +C: hand ( -- hand ) + 0 + over set-hand-delegate ; + +GENERIC: hand-gesture ( hand gesture -- ) + +M: object hand-gesture ( hand gesture -- ) 2drop ; + +: button/ ( n hand -- ) + [ hand-buttons unique ] keep set-hand-buttons ; + +: button\ ( n hand -- ) + [ hand-buttons remove ] keep set-hand-buttons ; + +M: button-down-event hand-gesture ( hand gesture -- ) + 2dup + dup button-event-x swap button-event-y rect> + swap set-hand-click-pos + button-event-button swap button/ ; + +M: button-up-event hand-gesture ( hand gesture -- ) + button-event-button swap button\ ; + +M: motion-event hand-gesture ( hand gesture -- ) + dup motion-event-x swap motion-event-y rot move-gadget ; + +M: hand redraw ( hand -- ) + drop world get redraw ; diff --git a/library/ui/paint.factor b/library/ui/paint.factor index 6e08f10349..0435cb90ee 100644 --- a/library/ui/paint.factor +++ b/library/ui/paint.factor @@ -21,7 +21,13 @@ SYMBOL: filled ! is the interior of the shape filled? GENERIC: draw ( obj -- ) -M: rect draw ( rect -- ) +M: ghost draw ( ghost -- ) + drop ; + +M: number draw ( point -- ) + >r surface get r> >rect rgb-color pixelColor ; + +M: rectangle draw ( rect -- ) >r surface get r> shape>screen rgb-color filled get [ boxColor ] [ rectangleColor ] ifte ; diff --git a/library/ui/shapes.factor b/library/ui/shapes.factor index 6c015c12e7..048ed402f2 100644 --- a/library/ui/shapes.factor +++ b/library/ui/shapes.factor @@ -45,38 +45,48 @@ M: number shape-h drop 0 ; M: number move-shape ( x y point -- point ) drop rect> ; ! A rectangle maps trivially to the shape protocol. -TUPLE: rect x y w h ; -M: rect shape-x rect-x ; -M: rect shape-y rect-y ; -M: rect shape-w rect-w ; -M: rect shape-h rect-h ; +TUPLE: rectangle x y w h ; +M: rectangle shape-x rectangle-x ; +M: rectangle shape-y rectangle-y ; +M: rectangle shape-w rectangle-w ; +M: rectangle shape-h rectangle-h ; : fix-neg ( a b c -- a+c b -c ) dup 0 < [ neg tuck >r >r + r> r> ] when ; -C: rect ( x y w h -- rect ) +C: rectangle ( x y w h -- rect ) #! We handle negative w/h for convinience. >r fix-neg >r fix-neg r> r> - [ set-rect-h ] keep - [ set-rect-w ] keep - [ set-rect-y ] keep - [ set-rect-x ] keep ; + [ set-rectangle-h ] keep + [ set-rectangle-w ] keep + [ set-rectangle-y ] keep + [ set-rectangle-x ] keep ; M: number resize-shape ( w h point -- rect ) - >rect 2swap ; + >rect 2swap ; -M: rect move-shape ( x y rect -- rect ) - [ rect-w ] keep rect-h ; +M: rectangle move-shape ( x y rect -- rect ) + [ rectangle-w ] keep rectangle-h ; -M: rect resize-shape ( w h rect -- rect ) - [ rect-x ] keep rect-y 2swap ; +M: rectangle resize-shape ( w h rect -- rect ) + [ rectangle-x ] keep rectangle-y 2swap ; -: rect-x-extents ( rect -- x1 x2 ) - dup rect-x x get + swap rect-w dupd + ; +: rectangle-x-extents ( rect -- x1 x2 ) + dup rectangle-x x get + swap rectangle-w dupd + ; -: rect-y-extents ( rect -- x1 x2 ) - dup rect-y y get + swap rect-h dupd + ; +: rectangle-y-extents ( rect -- x1 x2 ) + dup rectangle-y y get + swap rectangle-h dupd + ; -M: rect inside? ( point rect -- ? ) - over shape-x over rect-x-extents between? >r - swap shape-y swap rect-y-extents between? r> and ; +M: rectangle inside? ( point rect -- ? ) + over shape-x over rectangle-x-extents between? >r + swap shape-y swap rectangle-y-extents between? r> and ; + +! Delegates to a bounded shape, but absorbs all points. +WRAPPER: everywhere +M: everywhere inside? ( point world -- ? ) 2drop t ; + +M: everywhere move-shape ( x y everywhere -- ) + everywhere-delegate move-shape ; + +M: everywhere resize-shape ( w h everywhere -- ) + everywhere-delegate resize-shape ; diff --git a/library/ui/world.factor b/library/ui/world.factor index 740a0f915c..9c380bf527 100644 --- a/library/ui/world.factor +++ b/library/ui/world.factor @@ -1,53 +1,23 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets -USING: alien generic kernel lists math namespaces sdl sdl-event ; - -! The hand is a special gadget that holds mouse position and -! mouse button click state. -TUPLE: hand clicked buttons delegate ; - -C: hand ( -- hand ) 0 over set-hand-delegate ; - -GENERIC: hand-gesture ( hand gesture -- ) - -M: alien hand-gesture ( hand gesture -- ) 2drop ; - -: button/ ( n hand -- ) - [ hand-buttons unique ] keep set-hand-buttons ; - -: button\ ( n hand -- ) - [ hand-buttons remove ] keep set-hand-buttons ; - -M: button-down-event hand-gesture ( hand gesture -- ) - 2dup - dup button-event-x swap button-event-y rect> - swap set-hand-clicked - button-event-button swap button/ ; - -M: button-up-event hand-gesture ( hand gesture -- ) - button-event-button swap button\ ; - -M: motion-event hand-gesture ( hand gesture -- ) - dup motion-event-x swap motion-event-y rot move-gadget ; +USING: alien generic kernel lists math namespaces sdl sdl-event +sdl-video ; ! The world gadget is the top level gadget that all (visible) ! gadgets are contained in. The current world is stored in the ! world variable. TUPLE: world running? hand delegate redraw? ; -TUPLE: redraw-gesture ; -C: redraw-gesture ; - -: redraw ( gadget -- ) - swap handle-gesture ; - M: hand handle-gesture* ( gesture hand -- ? ) 2dup swap hand-gesture world get pick-up handle-gesture* ; : ( -- box ) - 0 0 1000 1000 ; + 0 0 0 0 + dup blue 3list color set-paint-property + dup t filled set-paint-property + ; C: world ( -- world ) over set-world-delegate @@ -62,7 +32,14 @@ M: alien world-gesture ( world gesture -- ) 2drop ; M: quit-event world-gesture ( world gesture -- ) drop f swap set-world-running? ; +M: resize-event world-gesture ( world gesture -- ? ) + dup resize-event-w swap resize-event-h + [ rot resize-gadget ] 2keep + 0 SDL_HWSURFACE SDL_RESIZABLE bitor init-screen + world get redraw ; + M: redraw-gesture world-gesture ( world gesture -- ) + drop t swap set-world-redraw? ; M: world handle-gesture* ( gesture world -- ? ) @@ -74,7 +51,8 @@ M: world handle-gesture* ( gesture world -- ? ) world get dup world-redraw? [ [ f over set-world-redraw? - draw + dup draw + world-hand draw ] with-surface ] [ drop @@ -89,4 +67,17 @@ M: world handle-gesture* ( gesture world -- ? ) ] ifte ] when ; +: init-world ( w h -- ) + t world get set-world-running? + t world get set-world-redraw? + world get resize-gadget ; + +: world-flags SDL_HWSURFACE SDL_RESIZABLE bitor ; + +: start-world ( w h -- ) + #! Start the Factor graphics subsystem with the given screen + #! dimensions. + 2dup init-world 0 world-flags + default-paint [ [ run-world ] with-screen ] bind ; + global [ world set ] bind From 0ae2b208296449556e7c08b28ad1747370efbd2b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 2 Feb 2005 02:47:10 +0000 Subject: [PATCH 046/122] working on UI gestures --- library/lists.factor | 7 ++++++- library/ui/boxes.factor | 3 ++- library/ui/gadgets.factor | 22 ++++++++++++++-------- library/ui/gestures.factor | 20 +++++++++++++++----- library/ui/hand.factor | 34 +++++++++++++++------------------- library/ui/paint.factor | 3 --- library/ui/world.factor | 31 +++++-------------------------- 7 files changed, 57 insertions(+), 63 deletions(-) diff --git a/library/lists.factor b/library/lists.factor index d93d7f195a..f1cea1f255 100644 --- a/library/lists.factor +++ b/library/lists.factor @@ -93,9 +93,14 @@ DEFER: tree-contains? swap [ with rot ] map 2nip ; inline : remove ( obj list -- list ) - #! Remove all occurrences of the object from the list. + #! Remove all occurrences of objects equal to this one from + #! the list. [ = not ] subset-with ; +: remq ( obj list -- list ) + #! Remove all occurrences of the object from the list. + [ eq? not ] subset-with ; + : length ( list -- length ) 0 swap [ drop 1 + ] each ; diff --git a/library/ui/boxes.factor b/library/ui/boxes.factor index 37668b581f..62f79a8eba 100644 --- a/library/ui/boxes.factor +++ b/library/ui/boxes.factor @@ -50,7 +50,8 @@ M: box pick-up* ( point box -- gadget ) ] with-translation ; : box- ( gadget box -- ) - 2dup box-contents remove swap tuck set-box-contents redraw + [ 2dup box-contents remq swap set-box-contents ] keep + redraw f swap set-gadget-parent ; : (box+) ( gadget box -- ) diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index 149245999e..992136316d 100644 --- a/library/ui/gadgets.factor +++ b/library/ui/gadgets.factor @@ -5,20 +5,21 @@ USING: generic hashtables kernel lists namespaces ; ! Gadget protocol. GENERIC: pick-up* ( point gadget -- gadget/t ) -GENERIC: handle-gesture* ( gesture gadget -- ? ) : pick-up ( point gadget -- gadget ) #! pick-up* returns t to mean 'this gadget', avoiding the #! exposed facade issue. tuck pick-up* dup t = [ drop ] [ nip ] ifte ; -! A gadget is a shape together with paint, and a reference to -! the gadget's parent. A gadget delegates to its shape. -TUPLE: gadget paint parent delegate ; +! A gadget is a shape, a paint, a mapping of gestures to +! actions, and a reference to the gadget's parent. A gadget +! delegates to its shape. +TUPLE: gadget paint gestures parent delegate ; C: gadget ( shape -- gadget ) [ set-gadget-delegate ] keep - [ swap set-gadget-paint ] keep ; + [ swap set-gadget-paint ] keep + [ swap set-gadget-gestures ] keep ; : paint-property ( gadget key -- value ) swap gadget-paint hash ; @@ -26,6 +27,12 @@ C: gadget ( shape -- gadget ) : set-paint-property ( gadget value key -- ) rot gadget-paint set-hash ; +: action ( gadget gesture -- quot ) + swap gadget-gestures hash ; + +: set-action ( gadget quot gesture -- ) + rot gadget-gestures set-hash ; + : with-gadget ( gadget quot -- ) #! All drawing done inside the quotation is done with the #! gadget's paint. If the gadget does not have any custom @@ -37,9 +44,7 @@ M: gadget draw ( gadget -- ) M: gadget pick-up* inside? ; -M: gadget handle-gesture* 2drop t ; - -GENERIC: redraw ( gadget -- ) +DEFER: redraw ( gadget -- ) : move-gadget ( x y gadget -- ) [ move-shape ] keep @@ -55,3 +60,4 @@ GENERIC: redraw ( gadget -- ) WRAPPER: ghost M: ghost draw drop ; M: ghost pick-up* 2drop f ; +M: ghost draw drop ; diff --git a/library/ui/gestures.factor b/library/ui/gestures.factor index 058eee2e39..7c9999996b 100644 --- a/library/ui/gestures.factor +++ b/library/ui/gestures.factor @@ -1,7 +1,14 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets -USING: generic kernel lists sdl-event ; +USING: alien generic hashtables kernel lists sdl-event ; + +: handle-gesture* ( gesture gadget -- ? ) + tuck gadget-gestures hash* dup [ + cdr call f + ] [ + 2drop t + ] ifte ; : handle-gesture ( gesture gadget -- ) #! If a gadget's handle-gesture* generic returns t, the @@ -17,8 +24,11 @@ USING: generic kernel lists sdl-event ; 2drop ] ifte ; -TUPLE: redraw-gesture ; -C: redraw-gesture ; +! Redraw gesture. Don't handle this yourself. +: redraw ( gadget -- ) + \ redraw swap handle-gesture ; -M: object redraw ( gadget -- ) - swap handle-gesture ; +! Mouse gestures are lists where the first element is one of: +SYMBOL: motion +SYMBOL: button-up +SYMBOL: button-down diff --git a/library/ui/hand.factor b/library/ui/hand.factor index 8868b5d743..e84289a177 100644 --- a/library/ui/hand.factor +++ b/library/ui/hand.factor @@ -4,37 +4,33 @@ IN: gadgets USING: alien generic kernel lists math namespaces sdl sdl-event sdl-video ; +SYMBOL: world + ! The hand is a special gadget that holds mouse position and ! mouse button click state. The hand's parent is the world, but ! it is special in that the world does not list it as part of ! its contents. TUPLE: hand click-pos clicked buttons delegate ; -C: hand ( -- hand ) +C: hand ( world -- hand ) 0 - over set-hand-delegate ; + over set-hand-delegate + [ set-gadget-parent ] keep ; -GENERIC: hand-gesture ( hand gesture -- ) +: motion-gesture ( gesture hand -- ) + #! Send the gesture to the gadget at the hand's position in + #! the world. + world get pick-up handle-gesture ; -M: object hand-gesture ( hand gesture -- ) 2drop ; +: button-gesture ( gesture hand -- ) + #! Send the gesture to the gadget at the hand's last click + #! position in the world. This is used to send a button up + #! to the gadget that was clicked, regardless of the mouse + #! position at the time of the button up. + hand-clicked handle-gesture ; : button/ ( n hand -- ) [ hand-buttons unique ] keep set-hand-buttons ; : button\ ( n hand -- ) [ hand-buttons remove ] keep set-hand-buttons ; - -M: button-down-event hand-gesture ( hand gesture -- ) - 2dup - dup button-event-x swap button-event-y rect> - swap set-hand-click-pos - button-event-button swap button/ ; - -M: button-up-event hand-gesture ( hand gesture -- ) - button-event-button swap button\ ; - -M: motion-event hand-gesture ( hand gesture -- ) - dup motion-event-x swap motion-event-y rot move-gadget ; - -M: hand redraw ( hand -- ) - drop world get redraw ; diff --git a/library/ui/paint.factor b/library/ui/paint.factor index 0435cb90ee..a0b9ec628b 100644 --- a/library/ui/paint.factor +++ b/library/ui/paint.factor @@ -21,9 +21,6 @@ SYMBOL: filled ! is the interior of the shape filled? GENERIC: draw ( obj -- ) -M: ghost draw ( ghost -- ) - drop ; - M: number draw ( point -- ) >r surface get r> >rect rgb-color pixelColor ; diff --git a/library/ui/world.factor b/library/ui/world.factor index 9c380bf527..a8e428a1a2 100644 --- a/library/ui/world.factor +++ b/library/ui/world.factor @@ -9,10 +9,6 @@ sdl-video ; ! world variable. TUPLE: world running? hand delegate redraw? ; -M: hand handle-gesture* ( gesture hand -- ? ) - 2dup swap hand-gesture - world get pick-up handle-gesture* ; - : ( -- box ) 0 0 0 0 dup blue 3list color set-paint-property @@ -23,27 +19,7 @@ C: world ( -- world ) over set-world-delegate t over set-world-running? t over set-world-redraw? - over set-world-hand ; - -GENERIC: world-gesture ( world gesture -- ) - -M: alien world-gesture ( world gesture -- ) 2drop ; - -M: quit-event world-gesture ( world gesture -- ) - drop f swap set-world-running? ; - -M: resize-event world-gesture ( world gesture -- ? ) - dup resize-event-w swap resize-event-h - [ rot resize-gadget ] 2keep - 0 SDL_HWSURFACE SDL_RESIZABLE bitor init-screen - world get redraw ; - -M: redraw-gesture world-gesture ( world gesture -- ) - - drop t swap set-world-redraw? ; - -M: world handle-gesture* ( gesture world -- ? ) - swap world-gesture f ; + dup over set-world-hand ; : my-hand ( -- hand ) world get world-hand ; @@ -58,10 +34,12 @@ M: world handle-gesture* ( gesture world -- ? ) drop ] ifte ; +DEFER: handle-event + : run-world ( -- ) world get world-running? [ dup SDL_WaitEvent 1 = [ - my-hand handle-gesture draw-world run-world + handle-event draw-world run-world ] [ drop ] ifte @@ -70,6 +48,7 @@ M: world handle-gesture* ( gesture world -- ? ) : init-world ( w h -- ) t world get set-world-running? t world get set-world-redraw? + world get [ t swap set-world-redraw? ] \ redraw set-action world get resize-gadget ; : world-flags SDL_HWSURFACE SDL_RESIZABLE bitor ; From 90bcf57e54f6d256a729be1493aac69f494216cd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 2 Feb 2005 03:00:55 +0000 Subject: [PATCH 047/122] missing file --- library/ui/events.factor | 40 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 40 insertions(+) create mode 100644 library/ui/events.factor diff --git a/library/ui/events.factor b/library/ui/events.factor new file mode 100644 index 0000000000..569aa54d17 --- /dev/null +++ b/library/ui/events.factor @@ -0,0 +1,40 @@ +! Copyright (C) 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: gadgets +USING: alien generic kernel lists math namespaces sdl sdl-event +sdl-video ; + +GENERIC: handle-event ( event -- ) + +M: alien handle-event ( event -- ) + drop ; + +M: quit-event handle-event ( event -- ) + drop f world get set-world-running? ; + +M: resize-event handle-event ( event -- ) + dup resize-event-w swap resize-event-h + [ world get resize-gadget ] 2keep + 0 SDL_HWSURFACE SDL_RESIZABLE bitor init-screen + world get redraw ; + +: button-event-pos ( event -- #{ x y }# ) + dup button-event-x swap button-event-y rect> ; + +M: button-down-event handle-event ( event -- ) + dup button-event-pos my-hand set-hand-click-pos + my-hand hand-click-pos world get pick-up + my-hand set-hand-clicked + button-event-button dup my-hand button/ + button-down swap 2list my-hand button-gesture ; + +M: button-up-event handle-event ( event -- ) + button-event-button + dup my-hand button\ + button-up swap 2list my-hand button-gesture + f my-hand set-hand-clicked + f my-hand set-hand-click-pos ; + +M: motion-event handle-event ( event -- ) + dup motion-event-x swap motion-event-y my-hand move-gadget + [ motion ] my-hand motion-gesture ; From 99f46aa3139163ca209a818ce458666370c37fc1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 2 Feb 2005 03:48:04 +0000 Subject: [PATCH 048/122] label gadget --- library/bootstrap/boot-stage2.factor | 2 ++ library/sdl/sdl-utils.factor | 26 ++++++++++++++++++++----- library/test/gadgets.factor | 10 ---------- library/ui/console.factor | 2 +- library/ui/gadgets.factor | 16 ++++++++------- library/ui/hand.factor | 2 +- library/ui/label.factor | 29 ++++++++++++++++++++++++++++ library/ui/paint.factor | 2 +- library/ui/world.factor | 2 +- 9 files changed, 65 insertions(+), 26 deletions(-) create mode 100644 library/ui/label.factor diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index d88965f0c2..06e6201b40 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -159,6 +159,8 @@ cpu "x86" = [ "/library/ui/gestures.factor" "/library/ui/hand.factor" "/library/ui/world.factor" + "/library/ui/label.factor" + "/library/ui/events.factor" ] [ dup print run-resource diff --git a/library/sdl/sdl-utils.factor b/library/sdl/sdl-utils.factor index efba5137a9..5113292f7e 100644 --- a/library/sdl/sdl-utils.factor +++ b/library/sdl/sdl-utils.factor @@ -42,6 +42,7 @@ USE: sdl-video USE: streams USE: strings USE: sdl-ttf +USE: hashtables SYMBOL: surface SYMBOL: width @@ -119,12 +120,23 @@ SYMBOL: fonts : ( name ptsize -- font ) >r resource-path swap cat2 r> TTF_OpenFont ; -: font ( name ptsize -- font ) +SYMBOL: logical-fonts + +: logical-font ( name -- name ) + dup logical-fonts get hash dup [ nip ] [ drop ] ifte ; + +global [ + {{ + [[ "Monospaced" "/fonts/VeraMono.ttf" ]] + }} logical-fonts set +] bind + +: lookup-font ( [[ name ptsize ]] -- font ) fonts get [ - 2dup cons get [ - 2nip + unswons logical-font swons dup get [ + nip ] [ - 2dup cons >r dup r> set + [ uncons dup ] keep set ] ifte* ] bind ; @@ -139,9 +151,13 @@ SYMBOL: fonts dup surface-w swap surface-h make-rect ; : draw-surface ( x y surface -- ) + surface get SDL_UnlockSurface [ [ surface-rect ] keep swap surface get 0 0 - ] keep surface-rect swap rot SDL_UpperBlit drop ; + ] keep surface-rect swap rot SDL_UpperBlit drop + surface get dup must-lock-surface? [ + SDL_LockSurface + ] when drop ; : draw-string ( x y font text fg bg -- width ) pick str-length 0 = [ diff --git a/library/test/gadgets.factor b/library/test/gadgets.factor index 322eba4137..8e36a5e28f 100644 --- a/library/test/gadgets.factor +++ b/library/test/gadgets.factor @@ -49,13 +49,3 @@ USING: gadgets kernel lists math namespaces test ; pick-up ] bind ] unit-test - -[ 30 ] [ - default-paint [ - 35 10 rect> - [ 10 30 50 70 ] [ funny-rect ] map - 0 0 200 200 - [ set-box-contents ] keep - pick-up shape-x - ] bind -] unit-test diff --git a/library/ui/console.factor b/library/ui/console.factor index 526507a0c2..c5cfaa506c 100644 --- a/library/ui/console.factor +++ b/library/ui/console.factor @@ -345,7 +345,7 @@ M: alien handle-event ( event -- ? ) ] ifte ; : set-console-font ( font ptsize ) - font dup console-font set + cons lookup-font dup console-font set TTF_FontHeight line-height set ; : init-console ( -- ) diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index 992136316d..06c0e66174 100644 --- a/library/ui/gadgets.factor +++ b/library/ui/gadgets.factor @@ -39,8 +39,7 @@ C: gadget ( shape -- gadget ) #! paint, just call the quotation. >r gadget-paint r> bind ; -M: gadget draw ( gadget -- ) - dup [ gadget-delegate draw ] with-gadget ; +M: gadget draw ( gadget -- ) drop ; M: gadget pick-up* inside? ; @@ -56,8 +55,11 @@ DEFER: redraw ( gadget -- ) [ set-gadget-delegate ] keep redraw ; -! An invisible gadget. -WRAPPER: ghost -M: ghost draw drop ; -M: ghost pick-up* 2drop f ; -M: ghost draw drop ; +! A simple gadget that just draws its shape. +TUPLE: stamp delegate ; + +C: stamp ( shape -- ) + swap over set-stamp-delegate ; + +M: stamp draw ( stamp -- ) + dup [ gadget-delegate draw ] with-gadget ; diff --git a/library/ui/hand.factor b/library/ui/hand.factor index e84289a177..c2c6663bb8 100644 --- a/library/ui/hand.factor +++ b/library/ui/hand.factor @@ -13,7 +13,7 @@ SYMBOL: world TUPLE: hand click-pos clicked buttons delegate ; C: hand ( world -- hand ) - 0 + 0 over set-hand-delegate [ set-gadget-parent ] keep ; diff --git a/library/ui/label.factor b/library/ui/label.factor new file mode 100644 index 0000000000..359ba0f6df --- /dev/null +++ b/library/ui/label.factor @@ -0,0 +1,29 @@ +! Copyright (C) 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: gadgets +USING: generic kernel lists math namespaces sdl ; + +! A label draws a text label, centered on the gadget's bounding +! box. +TUPLE: label text delegate ; + +: size-label ( label -- ) + [ + dup label-text swap gadget-paint + [ font get lookup-font ] bind + swap size-string + ] keep resize-gadget ; + +C: label ( text -- ) + 0 0 0 0 over set-label-delegate + [ set-label-text ] keep + [ size-label ] keep ; + +M: label draw ( label -- ) + dup shape-x x get + + over shape-y y get + + rot label-text + >r font get lookup-font r> + color get 3unlist make-color + white make-color + draw-string drop ; diff --git a/library/ui/paint.factor b/library/ui/paint.factor index a0b9ec628b..3885e34e2c 100644 --- a/library/ui/paint.factor +++ b/library/ui/paint.factor @@ -34,5 +34,5 @@ M: rectangle draw ( rect -- ) [[ y 0 ]] [[ color [ 0 0 0 ] ]] [[ filled f ]] - [[ font [ "Monospaced" 12 ] ]] + [[ font [[ "Monospaced" 12 ]] ]] }} ; diff --git a/library/ui/world.factor b/library/ui/world.factor index a8e428a1a2..91c60135da 100644 --- a/library/ui/world.factor +++ b/library/ui/world.factor @@ -10,7 +10,7 @@ sdl-video ; TUPLE: world running? hand delegate redraw? ; : ( -- box ) - 0 0 0 0 + 0 0 0 0 dup blue 3list color set-paint-property dup t filled set-paint-property ; From 09b8578afd483a91c2dd49258bb6cb732cb6821e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 3 Feb 2005 00:50:13 +0000 Subject: [PATCH 049/122] layouts --- TODO.FACTOR.txt | 4 ++ library/bootstrap/boot-stage2.factor | 3 +- library/ui/boxes.factor | 30 +++++++-------- library/ui/gadgets.factor | 45 +++++++++++++++++++--- library/ui/gestures.factor | 4 -- library/ui/{label.factor => labels.factor} | 11 +++--- library/ui/piles.factor | 17 ++++++++ library/ui/shapes.factor | 17 +++++++- library/ui/world.factor | 13 +++---- 9 files changed, 104 insertions(+), 40 deletions(-) rename library/ui/{label.factor => labels.factor} (89%) create mode 100644 library/ui/piles.factor diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 385fa2a008..219225c5cc 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -16,6 +16,9 @@ - doc comments of generics - proper ordering for classes - tuples: in/out syntax +- tuples: gracefully handle changing shape +- keep a list of getter/setter words +- default constructor + ffi: @@ -31,6 +34,7 @@ + listener/plugin: +- command to turn repl session into a source file - update plugin docs - extract word keeps indent - word preview for remote words diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index 06e6201b40..499a3b37b2 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -159,7 +159,8 @@ cpu "x86" = [ "/library/ui/gestures.factor" "/library/ui/hand.factor" "/library/ui/world.factor" - "/library/ui/label.factor" + "/library/ui/labels.factor" + "/library/ui/piles.factor" "/library/ui/events.factor" ] [ dup print diff --git a/library/ui/boxes.factor b/library/ui/boxes.factor index 62f79a8eba..37730747c7 100644 --- a/library/ui/boxes.factor +++ b/library/ui/boxes.factor @@ -4,11 +4,13 @@ IN: gadgets USING: generic hashtables kernel lists namespaces ; ! A box is a gadget holding other gadgets. -TUPLE: box contents delegate ; +TUPLE: box children delegate ; C: box ( gadget -- box ) [ set-box-delegate ] keep ; +M: box gadget-children box-children ; + M: general-list draw ( list -- ) [ draw ] each ; @@ -17,7 +19,7 @@ M: box draw ( box -- ) dup [ dup box-delegate draw - box-contents draw + box-children draw ] with-gadget ] with-translation ; @@ -37,25 +39,23 @@ M: box pick-up* ( point box -- gadget ) #! box, return f. Otherwise, see if the point is contained #! in any subgadget. If not, see if it is contained in the #! box delegate. - dup [ - 2dup inside? [ - 2dup box-contents pick-up dup [ - 2nip - ] [ - drop box-delegate pick-up* - ] ifte + 2dup inside? [ + 2dup [ translate ] keep box-children pick-up dup [ + 2nip ] [ - 2drop f + drop box-delegate pick-up* ] ifte - ] with-translation ; + ] [ + 2drop f + ] ifte ; : box- ( gadget box -- ) - [ 2dup box-contents remq swap set-box-contents ] keep - redraw + [ 2dup box-children remq swap set-box-children ] keep + relayout f swap set-gadget-parent ; : (box+) ( gadget box -- ) - [ box-contents cons ] keep set-box-contents ; + [ box-children cons ] keep set-box-children ; : unparent ( gadget -- ) dup gadget-parent dup [ box- ] [ 2drop ] ifte ; @@ -65,4 +65,4 @@ M: box pick-up* ( point box -- gadget ) over unparent dup pick set-gadget-parent tuck (box+) - redraw ; + relayout ; diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index 06c0e66174..9423d328c4 100644 --- a/library/ui/gadgets.factor +++ b/library/ui/gadgets.factor @@ -3,6 +3,11 @@ IN: gadgets USING: generic hashtables kernel lists namespaces ; +! A gadget is a shape, a paint, a mapping of gestures to +! actions, and a reference to the gadget's parent. A gadget +! delegates to its shape. +TUPLE: gadget paint gestures parent relayout? redraw? delegate ; + ! Gadget protocol. GENERIC: pick-up* ( point gadget -- gadget/t ) @@ -11,15 +16,31 @@ GENERIC: pick-up* ( point gadget -- gadget/t ) #! exposed facade issue. tuck pick-up* dup t = [ drop ] [ nip ] ifte ; -! A gadget is a shape, a paint, a mapping of gestures to -! actions, and a reference to the gadget's parent. A gadget -! delegates to its shape. -TUPLE: gadget paint gestures parent delegate ; +GENERIC: gadget-children ( gadget -- list ) +M: gadget gadget-children drop f ; + +GENERIC: layout* ( gadget -- ) +M: gadget layout* drop ; + +: layout ( gadget -- ) + #! Set the gadget's width and height to its preferred width + #! and height. The gadget's children are laid out first. + #! Note that nothing is done if the gadget does not need to + #! be laid out. + dup gadget-relayout? [ + f over set-gadget-relayout? + dup gadget-children [ layout ] each + layout* + ] [ + drop + ] ifte ; C: gadget ( shape -- gadget ) [ set-gadget-delegate ] keep [ swap set-gadget-paint ] keep - [ swap set-gadget-gestures ] keep ; + [ swap set-gadget-gestures ] keep + [ t swap set-gadget-relayout? ] keep + [ t swap set-gadget-redraw? ] keep ; : paint-property ( gadget key -- value ) swap gadget-paint hash ; @@ -43,7 +64,19 @@ M: gadget draw ( gadget -- ) drop ; M: gadget pick-up* inside? ; -DEFER: redraw ( gadget -- ) +: redraw ( gadget -- ) + #! Redraw a gadget before the next iteration of the event + #! loop. + t over set-gadget-redraw? + gadget-parent [ redraw ] when* ; + +: relayout ( gadget -- ) + #! Relayout a gadget before the next iteration of the event + #! loop. Since relayout also implies the visual + #! representation changed, we redraw the gadget too. + t over set-gadget-redraw? + t over set-gadget-relayout? + gadget-parent [ relayout ] when* ; : move-gadget ( x y gadget -- ) [ move-shape ] keep diff --git a/library/ui/gestures.factor b/library/ui/gestures.factor index 7c9999996b..844df6343e 100644 --- a/library/ui/gestures.factor +++ b/library/ui/gestures.factor @@ -24,10 +24,6 @@ USING: alien generic hashtables kernel lists sdl-event ; 2drop ] ifte ; -! Redraw gesture. Don't handle this yourself. -: redraw ( gadget -- ) - \ redraw swap handle-gesture ; - ! Mouse gestures are lists where the first element is one of: SYMBOL: motion SYMBOL: button-up diff --git a/library/ui/label.factor b/library/ui/labels.factor similarity index 89% rename from library/ui/label.factor rename to library/ui/labels.factor index 359ba0f6df..ce78627020 100644 --- a/library/ui/label.factor +++ b/library/ui/labels.factor @@ -7,18 +7,17 @@ USING: generic kernel lists math namespaces sdl ; ! box. TUPLE: label text delegate ; -: size-label ( label -- ) +C: label ( text -- ) + 0 0 0 0 over set-label-delegate + [ set-label-text ] keep ; + +M: label layout* ( label -- ) [ dup label-text swap gadget-paint [ font get lookup-font ] bind swap size-string ] keep resize-gadget ; -C: label ( text -- ) - 0 0 0 0 over set-label-delegate - [ set-label-text ] keep - [ size-label ] keep ; - M: label draw ( label -- ) dup shape-x x get + over shape-y y get + diff --git a/library/ui/piles.factor b/library/ui/piles.factor new file mode 100644 index 0000000000..5e8c2f8871 --- /dev/null +++ b/library/ui/piles.factor @@ -0,0 +1,17 @@ +! Copyright (C) 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: gadgets +USING: generic hashtables kernel lists math namespaces ; + +! A pile is a box that lays out its contents vertically. +TUPLE: pile delegate ; + +C: pile ( gadget -- pile ) + [ >r r> set-pile-delegate ] keep ; + +M: pile layout* ( pile -- ) + dup gadget-children run-heights >r >r + dup gadget-children max-width r> pick resize-gadget + gadget-children r> zip [ + uncons 0 swap rot move-gadget + ] each ; diff --git a/library/ui/shapes.factor b/library/ui/shapes.factor index 048ed402f2..31a25e6bd1 100644 --- a/library/ui/shapes.factor +++ b/library/ui/shapes.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets -USING: generic kernel math namespaces ; +USING: generic kernel lists math namespaces ; ! Shape protocol. Shapes are immutable; moving or resizing a ! shape makes a new shape. @@ -33,6 +33,21 @@ GENERIC: resize-shape ( w h shape -- shape ) r> call ] with-scope ; inline +: translate ( point shape -- point ) + #! Translate a point relative to the shape. + #! The rect>'ing of the given point won't be necessary as + #! soon as all generics delegate. + >r dup shape-x swap shape-y rect> r> + dup shape-x swap shape-y rect> - ; + +: max-width ( list -- n ) + #! The width of the widest shape. + [ shape-w ] map [ > ] top ; + +: run-heights ( list -- h list ) + #! Compute a list of accumilative sums of heights of shapes. + [ 0 swap [ over , shape-h + ] each ] make-list ; + ! A point, represented as a complex number, is the simplest type ! of shape. M: number inside? = ; diff --git a/library/ui/world.factor b/library/ui/world.factor index 91c60135da..326a7acb0a 100644 --- a/library/ui/world.factor +++ b/library/ui/world.factor @@ -7,7 +7,7 @@ sdl-video ; ! The world gadget is the top level gadget that all (visible) ! gadgets are contained in. The current world is stored in the ! world variable. -TUPLE: world running? hand delegate redraw? ; +TUPLE: world running? hand delegate ; : ( -- box ) 0 0 0 0 @@ -18,15 +18,14 @@ TUPLE: world running? hand delegate redraw? ; C: world ( -- world ) over set-world-delegate t over set-world-running? - t over set-world-redraw? dup over set-world-hand ; : my-hand ( -- hand ) world get world-hand ; : draw-world ( -- ) - world get dup world-redraw? [ + world get dup gadget-redraw? [ [ - f over set-world-redraw? + f over set-gadget-redraw? dup draw world-hand draw ] with-surface @@ -36,10 +35,12 @@ C: world ( -- world ) DEFER: handle-event +: layout-world world get layout ; + : run-world ( -- ) world get world-running? [ dup SDL_WaitEvent 1 = [ - handle-event draw-world run-world + handle-event draw-world layout-world run-world ] [ drop ] ifte @@ -47,8 +48,6 @@ DEFER: handle-event : init-world ( w h -- ) t world get set-world-running? - t world get set-world-redraw? - world get [ t swap set-world-redraw? ] \ redraw set-action world get resize-gadget ; : world-flags SDL_HWSURFACE SDL_RESIZABLE bitor ; From 5791ae2e42e4d28a053ec32d7c9bc7f49410eaaf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 3 Feb 2005 03:00:46 +0000 Subject: [PATCH 050/122] refactoring shape protocol for mutability; layouts --- library/bootstrap/boot-stage2.factor | 2 +- library/sdl/sdl-ttf.factor | 2 +- library/sdl/sdl-utils.factor | 8 +-- library/test/gadgets.factor | 22 ++++--- library/ui/boxes.factor | 14 +---- library/ui/events.factor | 4 +- library/ui/gadgets.factor | 25 ++------ library/ui/hand.factor | 2 +- library/ui/labels.factor | 3 +- library/ui/{piles.factor => layouts.factor} | 13 ++++ library/ui/paint.factor | 70 +++++++++++++++++---- library/ui/shapes.factor | 66 ++++++++++--------- library/ui/world.factor | 11 ++-- 13 files changed, 143 insertions(+), 99 deletions(-) rename library/ui/{piles.factor => layouts.factor} (58%) diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index 499a3b37b2..6c14842938 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -160,7 +160,7 @@ cpu "x86" = [ "/library/ui/hand.factor" "/library/ui/world.factor" "/library/ui/labels.factor" - "/library/ui/piles.factor" + "/library/ui/layouts.factor" "/library/ui/events.factor" ] [ dup print diff --git a/library/sdl/sdl-ttf.factor b/library/sdl/sdl-ttf.factor index 693fae82dd..3627e10e6e 100644 --- a/library/sdl/sdl-ttf.factor +++ b/library/sdl/sdl-ttf.factor @@ -95,7 +95,7 @@ END-STRUCT "surface*" "sdl-ttf" "TTF_RenderGlyph_Shaded" [ "void*" "ushort" "int" "int" ] alien-invoke ; : TTF_RenderText_Blended ( font text fg -- surface ) - "surface*" "sdl-ttf" "TTF_RenderText_Blended" [ "void*" "ushort" "int" ] alien-invoke ; + "surface*" "sdl-ttf" "TTF_RenderText_Blended" [ "void*" "char*" "int" ] alien-invoke ; : TTF_RenderGlyph_Blended ( font text fg -- surface ) "surface*" "sdl-ttf" "TTF_RenderGlyph_Blended" [ "void*" "ushort" "int" ] alien-invoke ; diff --git a/library/sdl/sdl-utils.factor b/library/sdl/sdl-utils.factor index 5113292f7e..9c793e86de 100644 --- a/library/sdl/sdl-utils.factor +++ b/library/sdl/sdl-utils.factor @@ -159,11 +159,11 @@ global [ SDL_LockSurface ] when drop ; -: draw-string ( x y font text fg bg -- width ) - pick str-length 0 = [ - 2drop 2drop 2drop 0 +: draw-string ( x y font text fg -- width ) + over str-length 0 = [ + 2drop 3drop 0 ] [ - TTF_RenderText_Shaded + TTF_RenderText_Blended [ draw-surface ] keep [ surface-w ] keep SDL_FreeSurface diff --git a/library/test/gadgets.factor b/library/test/gadgets.factor index 8e36a5e28f..a2e26ca202 100644 --- a/library/test/gadgets.factor +++ b/library/test/gadgets.factor @@ -5,21 +5,21 @@ USING: gadgets kernel lists math namespaces test ; [ 2000 x set 2000 y set - 2030 2040 rect> 10 20 300 400 inside? + 2030 2040 10 20 300 400 inside? ] with-scope ] unit-test [ f ] [ [ 2000 x set 2000 y set - 2500 2040 rect> 10 20 300 400 inside? + 2500 2040 10 20 300 400 inside? ] with-scope ] unit-test [ t ] [ [ -10 x set -20 y set - 0 0 rect> 10 20 300 400 inside? + 0 0 10 20 300 400 inside? ] with-scope ] unit-test [ 11 11 41 41 ] [ @@ -27,25 +27,29 @@ USING: gadgets kernel lists math namespaces test ; [ 1 x set 1 y set - 10 10 30 30 shape>screen + 10 10 30 30 shape>screen ] with-scope ] bind ] unit-test [ t ] [ default-paint [ - 0 0 rect> -10 -10 20 20 [ pick-up ] keep = + 0 0 -10 -10 20 20 [ pick-up ] keep = ] bind ] unit-test : funny-rect ( x -- rect ) - 10 10 30 - dup [ 255 0 0 ] color set-paint-property - dup t filled set-paint-property ; + 10 10 30 + dup [ 255 0 0 ] color set-paint-property ; [ f ] [ default-paint [ - 35 0 rect> + 35 0 [ 10 30 50 70 ] [ funny-rect ] map pick-up ] bind ] unit-test + +[ 1 3 2 ] [ #{ 1 2 }# #{ 3 4 }# x1/x2/y1 ] unit-test +[ 1 3 4 ] [ #{ 1 2 }# #{ 3 4 }# x1/x2/y2 ] unit-test +[ 1 2 4 ] [ #{ 1 2 }# #{ 3 4 }# x1/y1/y2 ] unit-test +[ 3 2 4 ] [ #{ 1 2 }# #{ 3 4 }# x2/y1/y2 ] unit-test diff --git a/library/ui/boxes.factor b/library/ui/boxes.factor index 37730747c7..97f5545dfa 100644 --- a/library/ui/boxes.factor +++ b/library/ui/boxes.factor @@ -11,17 +11,9 @@ C: box ( gadget -- box ) M: box gadget-children box-children ; -M: general-list draw ( list -- ) - [ draw ] each ; - -M: box draw ( box -- ) - dup [ - dup [ - dup - box-delegate draw - box-children draw - ] with-gadget - ] with-translation ; +M: box draw-shape ( box -- ) + dup box-delegate draw-gadget + dup [ box-children [ draw-gadget ] each ] with-translation ; M: general-list pick-up* ( point list -- gadget ) dup [ diff --git a/library/ui/events.factor b/library/ui/events.factor index 569aa54d17..da283fac09 100644 --- a/library/ui/events.factor +++ b/library/ui/events.factor @@ -18,8 +18,8 @@ M: resize-event handle-event ( event -- ) 0 SDL_HWSURFACE SDL_RESIZABLE bitor init-screen world get redraw ; -: button-event-pos ( event -- #{ x y }# ) - dup button-event-x swap button-event-y rect> ; +: button-event-pos ( event -- point ) + dup button-event-x swap button-event-y ; M: button-down-event handle-event ( event -- ) dup button-event-pos my-hand set-hand-click-pos diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index 9423d328c4..3840bbba9b 100644 --- a/library/ui/gadgets.factor +++ b/library/ui/gadgets.factor @@ -54,13 +54,11 @@ C: gadget ( shape -- gadget ) : set-action ( gadget quot gesture -- ) rot gadget-gestures set-hash ; -: with-gadget ( gadget quot -- ) - #! All drawing done inside the quotation is done with the +: draw-gadget ( gadget -- ) + #! All drawing done inside draw-shape is done with the #! gadget's paint. If the gadget does not have any custom #! paint, just call the quotation. - >r gadget-paint r> bind ; - -M: gadget draw ( gadget -- ) drop ; + dup gadget-paint [ draw-shape ] bind ; M: gadget pick-up* inside? ; @@ -79,20 +77,7 @@ M: gadget pick-up* inside? ; gadget-parent [ relayout ] when* ; : move-gadget ( x y gadget -- ) - [ move-shape ] keep - [ set-gadget-delegate ] keep - redraw ; + [ move-shape ] keep redraw ; : resize-gadget ( w h gadget -- ) - [ resize-shape ] keep - [ set-gadget-delegate ] keep - redraw ; - -! A simple gadget that just draws its shape. -TUPLE: stamp delegate ; - -C: stamp ( shape -- ) - swap over set-stamp-delegate ; - -M: stamp draw ( stamp -- ) - dup [ gadget-delegate draw ] with-gadget ; + [ resize-shape ] keep redraw ; diff --git a/library/ui/hand.factor b/library/ui/hand.factor index c2c6663bb8..8ac4df57c2 100644 --- a/library/ui/hand.factor +++ b/library/ui/hand.factor @@ -13,7 +13,7 @@ SYMBOL: world TUPLE: hand click-pos clicked buttons delegate ; C: hand ( world -- hand ) - 0 + 0 0 over set-hand-delegate [ set-gadget-parent ] keep ; diff --git a/library/ui/labels.factor b/library/ui/labels.factor index ce78627020..edd1c3a58f 100644 --- a/library/ui/labels.factor +++ b/library/ui/labels.factor @@ -18,11 +18,10 @@ M: label layout* ( label -- ) swap size-string ] keep resize-gadget ; -M: label draw ( label -- ) +M: label draw-shape ( label -- ) dup shape-x x get + over shape-y y get + rot label-text >r font get lookup-font r> color get 3unlist make-color - white make-color draw-string drop ; diff --git a/library/ui/piles.factor b/library/ui/layouts.factor similarity index 58% rename from library/ui/piles.factor rename to library/ui/layouts.factor index 5e8c2f8871..98b64764dc 100644 --- a/library/ui/piles.factor +++ b/library/ui/layouts.factor @@ -15,3 +15,16 @@ M: pile layout* ( pile -- ) gadget-children r> zip [ uncons 0 swap rot move-gadget ] each ; + +! A shelf is a box that lays out its contents horizontally. +TUPLE: shelf delegate ; + +C: shelf ( gadget -- pile ) + [ >r r> set-shelf-delegate ] keep ; + +M: shelf layout* ( pile -- ) + dup gadget-children run-widths >r >r + dup gadget-children max-height r> swap pick resize-gadget + gadget-children r> zip [ + uncons 0 rot move-gadget + ] each ; diff --git a/library/ui/paint.factor b/library/ui/paint.factor index 3885e34e2c..fa47112aa3 100644 --- a/library/ui/paint.factor +++ b/library/ui/paint.factor @@ -7,9 +7,8 @@ USING: generic kernel lists math namespaces sdl sdl-gfx ; ! dynamically-scoped variables. ! "Paint" is a namespace containing some or all of these values. -SYMBOL: color ! a list of three integers, 0..255. -SYMBOL: font ! a list of two elements, a font name and size. -SYMBOL: filled ! is the interior of the shape filled? +SYMBOL: color ! a list of three integers, 0..255. +SYMBOL: font ! a list of two elements, a font name and size. : shape>screen ( shape -- x1 y1 x2 y2 ) [ shape-x x get + ] keep @@ -19,20 +18,69 @@ SYMBOL: filled ! is the interior of the shape filled? : rgb-color ( -- rgba ) color get 3unlist rgb ; -GENERIC: draw ( obj -- ) +GENERIC: draw-shape ( obj -- ) -M: number draw ( point -- ) - >r surface get r> >rect rgb-color pixelColor ; +M: rectangle draw-shape drop ; -M: rectangle draw ( rect -- ) - >r surface get r> shape>screen rgb-color - filled get [ boxColor ] [ rectangleColor ] ifte ; +M: point draw-shape ( point -- ) + >r surface get r> dup point-x swap point-y + rgb-color pixelColor ; + +TUPLE: hollow-rect delegate ; + +C: hollow-rect ( x y w h -- rect ) + [ >r r> set-hollow-rect-delegate ] keep ; + +M: hollow-rect draw-shape ( rect -- ) + >r surface get r> shape>screen rgb-color rectangleColor ; + +TUPLE: plain-rect delegate ; + +C: plain-rect ( x y w h -- rect ) + [ >r r> set-plain-rect-delegate ] keep ; + +M: plain-rect draw-shape ( rect -- ) + >r surface get r> shape>screen rgb-color boxColor ; + +: x1/x2/y1 ( #{ x1 y1 }# #{ x2 y2 }# -- x1 x2 y1 ) + >r >rect r> real swap ; + +: x1/x2/y2 ( #{ x1 y1 }# #{ x2 y2 }# -- x1 x2 y2 ) + >r real r> >rect ; + +: x1/y1/y2 ( #{ x1 y1 }# #{ x2 y2 }# -- x1 y1 y2 ) + >r >rect r> imaginary ; + +: x2/y1/y2 ( #{ x1 y1 }# #{ x2 y2 }# -- x2 y1 y2 ) + >r imaginary r> >rect >r swap r> ; + +: (draw-bevel) ( #{ x1 y1 }# #{ x2 y2 }# -- ) + surface get pick pick x1/x2/y1 240 240 240 rgb hlineColor + surface get pick pick x1/x2/y2 192 192 192 rgb hlineColor + surface get pick pick x1/y1/y2 240 240 240 rgb vlineColor + surface get pick pick x2/y1/y2 192 192 192 rgb vlineColor + 2drop ; + +TUPLE: bevel-rect delegate bevel ; + +C: bevel-rect ( bevel x y w h -- rect ) + [ >r r> set-bevel-rect-delegate ] keep + [ set-bevel-rect-bevel ] keep ; + +: draw-bevel ( #{ x1 y1 }# #{ x2 y2 }# n -- ) + [ + pick over #{ 1 1 }# * + + pick pick #{ 1 1 }# * - + (draw-bevel) + ] repeat 2drop ; + +M: bevel-rect draw-shape ( rect -- ) + shape>screen >r >r rect> r> r> rect> 3 draw-bevel ; : default-paint ( -- paint ) {{ [[ x 0 ]] [[ y 0 ]] - [[ color [ 0 0 0 ] ]] - [[ filled f ]] + [[ color [ 160 160 160 ] ]] [[ font [[ "Monospaced" 12 ]] ]] }} ; diff --git a/library/ui/shapes.factor b/library/ui/shapes.factor index 31a25e6bd1..65001eee5e 100644 --- a/library/ui/shapes.factor +++ b/library/ui/shapes.factor @@ -20,8 +20,8 @@ GENERIC: shape-y GENERIC: shape-w GENERIC: shape-h -GENERIC: move-shape ( x y shape -- shape ) -GENERIC: resize-shape ( w h shape -- shape ) +GENERIC: move-shape ( x y shape -- ) +GENERIC: resize-shape ( w h shape -- ) : with-translation ( shape quot -- ) #! All drawing done inside the quotation is translated @@ -33,31 +33,44 @@ GENERIC: resize-shape ( w h shape -- shape ) r> call ] with-scope ; inline -: translate ( point shape -- point ) - #! Translate a point relative to the shape. - #! The rect>'ing of the given point won't be necessary as - #! soon as all generics delegate. - >r dup shape-x swap shape-y rect> r> - dup shape-x swap shape-y rect> - ; - : max-width ( list -- n ) #! The width of the widest shape. [ shape-w ] map [ > ] top ; +: max-height ( list -- n ) + #! The height of the tallest shape. + [ shape-h ] map [ > ] top ; + +: run-widths ( list -- w list ) + #! Compute a list of running sums of widths of shapes. + [ 0 swap [ over , shape-w + ] each ] make-list ; + : run-heights ( list -- h list ) - #! Compute a list of accumilative sums of heights of shapes. + #! Compute a list of running sums of heights of shapes. [ 0 swap [ over , shape-h + ] each ] make-list ; -! A point, represented as a complex number, is the simplest type -! of shape. -M: number inside? = ; +! A point is the simplest shape. +TUPLE: point x y ; -M: number shape-x real ; -M: number shape-y imaginary ; -M: number shape-w drop 0 ; -M: number shape-h drop 0 ; +C: point ( x y -- point ) + [ set-point-y ] keep [ set-point-x ] keep ; -M: number move-shape ( x y point -- point ) drop rect> ; +M: point inside? ( point point -- ) + over shape-x over point-x = >r + swap shape-y swap point-y = r> and ; + +M: point shape-x point-x ; +M: point shape-y point-y ; +M: point shape-w drop 0 ; +M: point shape-h drop 0 ; + +M: point move-shape ( x y point -- ) + tuck set-point-y set-point-x ; + +: translate ( point shape -- point ) + #! Translate a point relative to the shape. + over shape-y over shape-y - >r + swap shape-x swap shape-x - r> ; ! A rectangle maps trivially to the shape protocol. TUPLE: rectangle x y w h ; @@ -77,14 +90,11 @@ C: rectangle ( x y w h -- rect ) [ set-rectangle-y ] keep [ set-rectangle-x ] keep ; -M: number resize-shape ( w h point -- rect ) - >rect 2swap ; +M: rectangle move-shape ( x y rect -- ) + tuck set-rectangle-y set-rectangle-x ; -M: rectangle move-shape ( x y rect -- rect ) - [ rectangle-w ] keep rectangle-h ; - -M: rectangle resize-shape ( w h rect -- rect ) - [ rectangle-x ] keep rectangle-y 2swap ; +M: rectangle resize-shape ( w h rect -- ) + tuck set-rectangle-h set-rectangle-w ; : rectangle-x-extents ( rect -- x1 x2 ) dup rectangle-x x get + swap rectangle-w dupd + ; @@ -99,9 +109,3 @@ M: rectangle inside? ( point rect -- ? ) ! Delegates to a bounded shape, but absorbs all points. WRAPPER: everywhere M: everywhere inside? ( point world -- ? ) 2drop t ; - -M: everywhere move-shape ( x y everywhere -- ) - everywhere-delegate move-shape ; - -M: everywhere resize-shape ( w h everywhere -- ) - everywhere-delegate resize-shape ; diff --git a/library/ui/world.factor b/library/ui/world.factor index 326a7acb0a..739e512867 100644 --- a/library/ui/world.factor +++ b/library/ui/world.factor @@ -10,9 +10,8 @@ sdl-video ; TUPLE: world running? hand delegate ; : ( -- box ) - 0 0 0 0 - dup blue 3list color set-paint-property - dup t filled set-paint-property + 0 0 0 0 + dup [ 216 216 216 ] color set-paint-property ; C: world ( -- world ) @@ -26,8 +25,8 @@ C: world ( -- world ) world get dup gadget-redraw? [ [ f over set-gadget-redraw? - dup draw - world-hand draw + dup draw-gadget + world-hand draw-gadget ] with-surface ] [ drop @@ -40,7 +39,7 @@ DEFER: handle-event : run-world ( -- ) world get world-running? [ dup SDL_WaitEvent 1 = [ - handle-event draw-world layout-world run-world + handle-event layout-world draw-world run-world ] [ drop ] ifte From 3e4d15c835aff8a24a8c068c2a629faa10d94f3e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 3 Feb 2005 23:18:47 +0000 Subject: [PATCH 051/122] removed boxes; all gadgets can contain children now --- library/bootstrap/boot-stage2.factor | 3 +- library/ui/boxes.factor | 60 ----------------------- library/ui/gadgets.factor | 72 +++++++++------------------- library/ui/hand.factor | 38 ++++++++++++++- library/ui/layouts.factor | 32 +++++++++++-- library/ui/paint.factor | 17 +++++++ library/ui/world.factor | 3 +- 7 files changed, 105 insertions(+), 120 deletions(-) delete mode 100644 library/ui/boxes.factor diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index 6c14842938..8b9ae69ec7 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -153,9 +153,8 @@ cpu "x86" = [ "/library/ui/line-editor.factor" "/library/ui/console.factor" "/library/ui/shapes.factor" - "/library/ui/paint.factor" "/library/ui/gadgets.factor" - "/library/ui/boxes.factor" + "/library/ui/paint.factor" "/library/ui/gestures.factor" "/library/ui/hand.factor" "/library/ui/world.factor" diff --git a/library/ui/boxes.factor b/library/ui/boxes.factor deleted file mode 100644 index 97f5545dfa..0000000000 --- a/library/ui/boxes.factor +++ /dev/null @@ -1,60 +0,0 @@ -! Copyright (C) 2005 Slava Pestov. -! See http://factor.sf.net/license.txt for BSD license. -IN: gadgets -USING: generic hashtables kernel lists namespaces ; - -! A box is a gadget holding other gadgets. -TUPLE: box children delegate ; - -C: box ( gadget -- box ) - [ set-box-delegate ] keep ; - -M: box gadget-children box-children ; - -M: box draw-shape ( box -- ) - dup box-delegate draw-gadget - dup [ box-children [ draw-gadget ] each ] with-translation ; - -M: general-list pick-up* ( point list -- gadget ) - dup [ - 2dup car pick-up dup [ - 2nip - ] [ - drop cdr pick-up - ] ifte - ] [ - 2drop f - ] ifte ; - -M: box pick-up* ( point box -- gadget ) - #! The logic is thus. If the point is definately outside the - #! box, return f. Otherwise, see if the point is contained - #! in any subgadget. If not, see if it is contained in the - #! box delegate. - 2dup inside? [ - 2dup [ translate ] keep box-children pick-up dup [ - 2nip - ] [ - drop box-delegate pick-up* - ] ifte - ] [ - 2drop f - ] ifte ; - -: box- ( gadget box -- ) - [ 2dup box-children remq swap set-box-children ] keep - relayout - f swap set-gadget-parent ; - -: (box+) ( gadget box -- ) - [ box-children cons ] keep set-box-children ; - -: unparent ( gadget -- ) - dup gadget-parent dup [ box- ] [ 2drop ] ifte ; - -: box+ ( gadget box -- ) - #! Add a gadget to a box. - over unparent - dup pick set-gadget-parent - tuck (box+) - relayout ; diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index 3840bbba9b..4d04a70660 100644 --- a/library/ui/gadgets.factor +++ b/library/ui/gadgets.factor @@ -6,34 +6,10 @@ USING: generic hashtables kernel lists namespaces ; ! A gadget is a shape, a paint, a mapping of gestures to ! actions, and a reference to the gadget's parent. A gadget ! delegates to its shape. -TUPLE: gadget paint gestures parent relayout? redraw? delegate ; - -! Gadget protocol. -GENERIC: pick-up* ( point gadget -- gadget/t ) - -: pick-up ( point gadget -- gadget ) - #! pick-up* returns t to mean 'this gadget', avoiding the - #! exposed facade issue. - tuck pick-up* dup t = [ drop ] [ nip ] ifte ; - -GENERIC: gadget-children ( gadget -- list ) -M: gadget gadget-children drop f ; - -GENERIC: layout* ( gadget -- ) -M: gadget layout* drop ; - -: layout ( gadget -- ) - #! Set the gadget's width and height to its preferred width - #! and height. The gadget's children are laid out first. - #! Note that nothing is done if the gadget does not need to - #! be laid out. - dup gadget-relayout? [ - f over set-gadget-relayout? - dup gadget-children [ layout ] each - layout* - ] [ - drop - ] ifte ; +TUPLE: gadget + paint gestures + relayout? redraw? + parent children delegate ; C: gadget ( shape -- gadget ) [ set-gadget-delegate ] keep @@ -54,30 +30,26 @@ C: gadget ( shape -- gadget ) : set-action ( gadget quot gesture -- ) rot gadget-gestures set-hash ; -: draw-gadget ( gadget -- ) - #! All drawing done inside draw-shape is done with the - #! gadget's paint. If the gadget does not have any custom - #! paint, just call the quotation. - dup gadget-paint [ draw-shape ] bind ; - -M: gadget pick-up* inside? ; - -: redraw ( gadget -- ) - #! Redraw a gadget before the next iteration of the event - #! loop. - t over set-gadget-redraw? - gadget-parent [ redraw ] when* ; - -: relayout ( gadget -- ) - #! Relayout a gadget before the next iteration of the event - #! loop. Since relayout also implies the visual - #! representation changed, we redraw the gadget too. - t over set-gadget-redraw? - t over set-gadget-relayout? - gadget-parent [ relayout ] when* ; - : move-gadget ( x y gadget -- ) [ move-shape ] keep redraw ; : resize-gadget ( w h gadget -- ) [ resize-shape ] keep redraw ; + +: box- ( gadget box -- ) + [ 2dup gadget-children remq swap set-gadget-children ] keep + relayout + f swap set-gadget-parent ; + +: (box+) ( gadget box -- ) + [ gadget-children cons ] keep set-gadget-children ; + +: unparent ( gadget -- ) + dup gadget-parent dup [ box- ] [ 2drop ] ifte ; + +: box+ ( gadget box -- ) + #! Add a gadget to a box. + over unparent + dup pick set-gadget-parent + tuck (box+) + relayout ; diff --git a/library/ui/hand.factor b/library/ui/hand.factor index 8ac4df57c2..16fe9cff91 100644 --- a/library/ui/hand.factor +++ b/library/ui/hand.factor @@ -4,7 +4,41 @@ IN: gadgets USING: alien generic kernel lists math namespaces sdl sdl-event sdl-video ; -SYMBOL: world +DEFER: pick-up* + +: pick-up-list ( point list -- gadget ) + dup [ + 2dup car pick-up dup [ + 2nip + ] [ + drop cdr pick-up-list + ] ifte + ] [ + 2drop f + ] ifte ; + +: pick-up* ( point gadget -- gadget/t ) + #! The logic is thus. If the point is definately outside the + #! box, return f. Otherwise, see if the point is contained + #! in any subgadget. If not, see if it is contained in the + #! box delegate. + 2dup inside? [ + 2dup [ translate ] keep + gadget-children pick-up-list dup [ + 2nip + ] [ + drop inside? + ] ifte + ] [ + 2drop f + ] ifte ; + +: pick-up ( point gadget -- gadget ) + #! pick-up* returns t to mean 'this gadget', avoiding the + #! exposed facade issue. + tuck pick-up* dup t = [ drop ] [ nip ] ifte ; + +DEFER: world ! The hand is a special gadget that holds mouse position and ! mouse button click state. The hand's parent is the world, but @@ -13,7 +47,7 @@ SYMBOL: world TUPLE: hand click-pos clicked buttons delegate ; C: hand ( world -- hand ) - 0 0 + 0 0 over set-hand-delegate [ set-gadget-parent ] keep ; diff --git a/library/ui/layouts.factor b/library/ui/layouts.factor index 98b64764dc..3aa42fce4c 100644 --- a/library/ui/layouts.factor +++ b/library/ui/layouts.factor @@ -3,11 +3,14 @@ IN: gadgets USING: generic hashtables kernel lists math namespaces ; +GENERIC: layout* ( gadget -- ) +M: gadget layout* drop ; + ! A pile is a box that lays out its contents vertically. TUPLE: pile delegate ; -C: pile ( gadget -- pile ) - [ >r r> set-pile-delegate ] keep ; +C: pile ( shape -- pile ) + [ >r r> set-pile-delegate ] keep ; M: pile layout* ( pile -- ) dup gadget-children run-heights >r >r @@ -19,8 +22,8 @@ M: pile layout* ( pile -- ) ! A shelf is a box that lays out its contents horizontally. TUPLE: shelf delegate ; -C: shelf ( gadget -- pile ) - [ >r r> set-shelf-delegate ] keep ; +C: shelf ( shape -- pile ) + [ >r r> set-shelf-delegate ] keep ; M: shelf layout* ( pile -- ) dup gadget-children run-widths >r >r @@ -28,3 +31,24 @@ M: shelf layout* ( pile -- ) gadget-children r> zip [ uncons 0 rot move-gadget ] each ; + +: relayout ( gadget -- ) + #! Relayout a gadget before the next iteration of the event + #! loop. Since relayout also implies the visual + #! representation changed, we redraw the gadget too. + t over set-gadget-redraw? + t over set-gadget-relayout? + gadget-parent [ relayout ] when* ; + +: layout ( gadget -- ) + #! Set the gadget's width and height to its preferred width + #! and height. The gadget's children are laid out first. + #! Note that nothing is done if the gadget does not need to + #! be laid out. + dup gadget-relayout? [ + f over set-gadget-relayout? + dup gadget-children [ layout ] each + layout* + ] [ + drop + ] ifte ; diff --git a/library/ui/paint.factor b/library/ui/paint.factor index fa47112aa3..c45e6aafaf 100644 --- a/library/ui/paint.factor +++ b/library/ui/paint.factor @@ -84,3 +84,20 @@ M: bevel-rect draw-shape ( rect -- ) [[ color [ 160 160 160 ] ]] [[ font [[ "Monospaced" 12 ]] ]] }} ; + +: draw-gadget ( gadget -- ) + #! All drawing done inside draw-shape is done with the + #! gadget's paint. If the gadget does not have any custom + #! paint, just call the quotation. + dup gadget-paint [ + dup draw-shape + dup [ + gadget-children [ draw-gadget ] each + ] with-translation + ] bind ; + +: redraw ( gadget -- ) + #! Redraw a gadget before the next iteration of the event + #! loop. + t over set-gadget-redraw? + gadget-parent [ redraw ] when* ; diff --git a/library/ui/world.factor b/library/ui/world.factor index 739e512867..27ba50ef98 100644 --- a/library/ui/world.factor +++ b/library/ui/world.factor @@ -11,8 +11,7 @@ TUPLE: world running? hand delegate ; : ( -- box ) 0 0 0 0 - dup [ 216 216 216 ] color set-paint-property - ; + dup [ 216 216 216 ] color set-paint-property ; C: world ( -- world ) over set-world-delegate From 68c98205bc7e4470588f15b7c026b51f8b9d5216 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Feb 2005 00:11:06 +0000 Subject: [PATCH 052/122] borders of various kinds --- library/ui/layouts.factor | 75 +++++++++++++++++++++++++++++---------- 1 file changed, 56 insertions(+), 19 deletions(-) diff --git a/library/ui/layouts.factor b/library/ui/layouts.factor index 3aa42fce4c..3037620f3d 100644 --- a/library/ui/layouts.factor +++ b/library/ui/layouts.factor @@ -6,6 +6,27 @@ USING: generic hashtables kernel lists math namespaces ; GENERIC: layout* ( gadget -- ) M: gadget layout* drop ; +: relayout ( gadget -- ) + #! Relayout a gadget before the next iteration of the event + #! loop. Since relayout also implies the visual + #! representation changed, we redraw the gadget too. + t over set-gadget-redraw? + t over set-gadget-relayout? + gadget-parent [ relayout ] when* ; + +: layout ( gadget -- ) + #! Set the gadget's width and height to its preferred width + #! and height. The gadget's children are laid out first. + #! Note that nothing is done if the gadget does not need to + #! be laid out. + dup gadget-relayout? [ + f over set-gadget-relayout? + dup gadget-children [ layout ] each + layout* + ] [ + drop + ] ifte ; + ! A pile is a box that lays out its contents vertically. TUPLE: pile delegate ; @@ -32,23 +53,39 @@ M: shelf layout* ( pile -- ) uncons 0 rot move-gadget ] each ; -: relayout ( gadget -- ) - #! Relayout a gadget before the next iteration of the event - #! loop. Since relayout also implies the visual - #! representation changed, we redraw the gadget too. - t over set-gadget-redraw? - t over set-gadget-relayout? - gadget-parent [ relayout ] when* ; +! A border lays out its children on top of each other, all with +! a 5-pixel padding. +TUPLE: border size delegate ; -: layout ( gadget -- ) - #! Set the gadget's width and height to its preferred width - #! and height. The gadget's children are laid out first. - #! Note that nothing is done if the gadget does not need to - #! be laid out. - dup gadget-relayout? [ - f over set-gadget-relayout? - dup gadget-children [ layout ] each - layout* - ] [ - drop - ] ifte ; +C: border ( delegate size -- border ) + [ set-border-size ] keep [ set-border-delegate ] keep ; + +: standard-border ( child delegate -- border ) + 5 [ box+ ] keep ; + +: empty-border ( child -- border ) + 0 0 0 0 standard-border ; + +: bevel-border ( child -- border ) + 3 0 0 0 0 standard-border ; + +: size-border ( border -- ) + dup gadget-children + dup max-width pick border-size 2 * + + swap max-height pick border-size 2 * + + rot resize-gadget ; + +: layout-border-x/y ( border -- ) + dup gadget-children [ + >r border-size dup r> move-gadget + ] each-with ; + +: layout-border-w/h ( border -- ) + [ + dup shape-h over border-size - >r + dup shape-w swap border-size - r> + ] keep + gadget-children [ >r 2dup r> resize-gadget ] each 2drop ; + +M: border layout* ( border -- ) + dup size-border dup layout-border-x/y layout-border-w/h ; From 3ba50f6665a21e56a8518219a15e3e9f83fae14c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Feb 2005 03:21:51 +0000 Subject: [PATCH 053/122] buttons now update their appearance when pressed --- library/bootstrap/boot-stage2.factor | 2 +- library/sdl/sdl-event.factor | 4 +-- library/sdl/sdl-utils.factor | 13 +++---- library/ui/buttons.factor | 17 ++++++++++ library/ui/console.factor | 8 ++--- library/ui/gadgets.factor | 14 ++++++++ library/ui/hand.factor | 4 +-- library/ui/labels.factor | 2 +- library/ui/layouts.factor | 16 +++------ library/ui/paint.factor | 47 +++++++++++++------------ library/ui/shapes.factor | 4 --- library/ui/world.factor | 51 ++++++++++++++++++++-------- 12 files changed, 112 insertions(+), 70 deletions(-) create mode 100644 library/ui/buttons.factor diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index 8b9ae69ec7..d31a1673c4 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -157,9 +157,9 @@ cpu "x86" = [ "/library/ui/paint.factor" "/library/ui/gestures.factor" "/library/ui/hand.factor" + "/library/ui/layouts.factor" "/library/ui/world.factor" "/library/ui/labels.factor" - "/library/ui/layouts.factor" "/library/ui/events.factor" ] [ dup print diff --git a/library/sdl/sdl-event.factor b/library/sdl/sdl-event.factor index d1043f7b4b..a51c4613d4 100644 --- a/library/sdl/sdl-event.factor +++ b/library/sdl/sdl-event.factor @@ -234,8 +234,8 @@ BEGIN-UNION: event MEMBER: user-event END-UNION -: SDL_WaitEvent ( event -- ) - "int" "sdl" "SDL_WaitEvent" [ "event*" ] alien-invoke ; +: SDL_WaitEvent ( event -- ? ) + "bool" "sdl" "SDL_WaitEvent" [ "event*" ] alien-invoke ; : SDL_PollEvent ( event -- ? ) "bool" "sdl" "SDL_PollEvent" [ "event*" ] alien-invoke ; diff --git a/library/sdl/sdl-utils.factor b/library/sdl/sdl-utils.factor index 9c793e86de..6f462ffc91 100644 --- a/library/sdl/sdl-utils.factor +++ b/library/sdl/sdl-utils.factor @@ -59,7 +59,8 @@ SYMBOL: surface SDL_INIT_EVERYTHING SDL_Init drop TTF_Init [ >r init-screen r> call SDL_Quit ] with-scope ; inline -: rgb ( r g b -- n ) +: rgb ( [ r g b ] -- n ) + 3unlist 255 swap 8 shift bitor swap 16 shift bitor @@ -73,11 +74,11 @@ SYMBOL: surface swap 8 shift bitor swap bitor ; -: black 0 0 0 ; -: white 255 255 255 ; -: red 255 0 0 ; -: green 0 255 0 ; -: blue 0 0 255 ; +: black [ 0 0 0 ] ; +: white [ 255 255 255 ] ; +: red [ 255 0 0 ] ; +: green [ 0 255 0 ] ; +: blue [ 0 0 255 ] ; : clear-surface ( color -- ) >r surface get 0 0 width get height get r> boxColor ; diff --git a/library/ui/buttons.factor b/library/ui/buttons.factor new file mode 100644 index 0000000000..8a7dcf4dd0 --- /dev/null +++ b/library/ui/buttons.factor @@ -0,0 +1,17 @@ +! Copyright (C) 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: gadgets +USING: generic kernel lists math namespaces sdl ; + +: button-pressed ( button -- ) + dup f bevel-up? set-paint-property redraw ; + +: button-released ( button -- ) + dup t bevel-up? set-paint-property redraw ; + +: