From b0ad7dfebc5d176c303f482d643fdccbe724ec18 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Wed, 1 Oct 2008 19:58:53 -0700 Subject: [PATCH 001/150] Adding bin-packing routines in extra/math/binpack. --- extra/math/binpack/authors.txt | 1 + extra/math/binpack/binpack-docs.factor | 19 +++++++++++++++++++ extra/math/binpack/binpack-tests.factor | 11 +++++++++++ extra/math/binpack/binpack.factor | 21 +++++++++++++++++++++ extra/math/binpack/summary.txt | 1 + 5 files changed, 53 insertions(+) create mode 100644 extra/math/binpack/authors.txt create mode 100644 extra/math/binpack/binpack-docs.factor create mode 100644 extra/math/binpack/binpack-tests.factor create mode 100644 extra/math/binpack/binpack.factor create mode 100644 extra/math/binpack/summary.txt diff --git a/extra/math/binpack/authors.txt b/extra/math/binpack/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/extra/math/binpack/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/extra/math/binpack/binpack-docs.factor b/extra/math/binpack/binpack-docs.factor new file mode 100644 index 0000000000..36a29c7aa1 --- /dev/null +++ b/extra/math/binpack/binpack-docs.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2008 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: help.syntax help.markup kernel assocs sequences quotations ; + +IN: math.binpack + +HELP: binpack +{ $values { "assoc" assoc } { "n" "number of bins" } { "bins" "packed bins" } } +{ $description "Packs the (key, value) pairs into the specified number of bins, using the value as a weight." } ; + +HELP: binpack* +{ $values { "items" sequence } { "n" "number of bins" } { "bins" "packed bins" } } +{ $description "Packs a sequence of numbers into the specified number of bins." } ; + +HELP: binpack! +{ $values { "items" sequence } { "quot" quotation } { "n" "number of bins" } { "bins" "packed bins" } } +{ $description "Packs a sequence of items into the specified number of bins, using the quotatino to determine the weight." } ; + diff --git a/extra/math/binpack/binpack-tests.factor b/extra/math/binpack/binpack-tests.factor new file mode 100644 index 0000000000..6f94b8ce22 --- /dev/null +++ b/extra/math/binpack/binpack-tests.factor @@ -0,0 +1,11 @@ +! Copyright (C) 2008 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: kernel tools.test ; + +[ t ] [ { { 3 } { 2 1 } } { 1 2 3 } 2 binpack-numbers = ] unit-test + +[ t ] [ { { 1000 } { 100 30 } { 70 40 23 } { 60 60 7 3 } } + { 100 23 40 60 1000 30 60 07 70 03 } 3 binpack-numbers = ] unit-test + + diff --git a/extra/math/binpack/binpack.factor b/extra/math/binpack/binpack.factor new file mode 100644 index 0000000000..6885789ee1 --- /dev/null +++ b/extra/math/binpack/binpack.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2008 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: sequences kernel arrays vectors accessors assocs sorting math math.functions ; + +IN: math.binpack + +: (binpack) ( bins item -- ) + swap dup [ [ second ] map sum ] map swap zip sort-keys values first push ; + +: binpack ( assoc n -- bins ) + [ sort-values reverse [ length ] keep swap ] dip + [ / ceiling ] keep [ ] map + swap [ dupd (binpack) ] each ; + +: binpack* ( items n -- bins ) + [ dup zip ] dip binpack [ keys ] map ; + +: binpack! ( items quot n -- bins ) + [ dup ] 2dip [ map zip ] dip binpack [ keys ] map ; + diff --git a/extra/math/binpack/summary.txt b/extra/math/binpack/summary.txt new file mode 100644 index 0000000000..c8b91966bb --- /dev/null +++ b/extra/math/binpack/summary.txt @@ -0,0 +1 @@ +Bin-packing algorithms. From bce227c8f33215f620f11a16a2b673d17caa5226 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Wed, 1 Oct 2008 20:05:08 -0700 Subject: [PATCH 002/150] math-binpack: Fix incorrect array size, and update tests. --- extra/math/binpack/binpack-tests.factor | 10 ++++++---- extra/math/binpack/binpack.factor | 2 +- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/extra/math/binpack/binpack-tests.factor b/extra/math/binpack/binpack-tests.factor index 6f94b8ce22..d0d4630484 100644 --- a/extra/math/binpack/binpack-tests.factor +++ b/extra/math/binpack/binpack-tests.factor @@ -1,11 +1,13 @@ ! Copyright (C) 2008 John Benediktsson ! See http://factorcode.org/license.txt for BSD license -USING: kernel tools.test ; +USING: kernel tools.test math.binpack ; -[ t ] [ { { 3 } { 2 1 } } { 1 2 3 } 2 binpack-numbers = ] unit-test +[ t ] [ { V{ } } { } 1 binpack = ] unit-test -[ t ] [ { { 1000 } { 100 30 } { 70 40 23 } { 60 60 7 3 } } - { 100 23 40 60 1000 30 60 07 70 03 } 3 binpack-numbers = ] unit-test +[ t ] [ { { 3 } { 2 1 } } { 1 2 3 } 2 binpack* = ] unit-test + +[ t ] [ { { 1000 } { 100 60 30 7 } { 70 60 40 23 3 } } + { 100 23 40 60 1000 30 60 07 70 03 } 3 binpack* = ] unit-test diff --git a/extra/math/binpack/binpack.factor b/extra/math/binpack/binpack.factor index 6885789ee1..f6473f2e25 100644 --- a/extra/math/binpack/binpack.factor +++ b/extra/math/binpack/binpack.factor @@ -10,7 +10,7 @@ IN: math.binpack : binpack ( assoc n -- bins ) [ sort-values reverse [ length ] keep swap ] dip - [ / ceiling ] keep [ ] map + [ / ceiling ] keep swap [ ] map swap [ dupd (binpack) ] each ; : binpack* ( items n -- bins ) From 1c76a6865a310a10035fbf8806ff4f5b27590f4d Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Wed, 1 Oct 2008 23:44:45 -0700 Subject: [PATCH 003/150] math-binpack: Some cleanups recommended on IRC. --- extra/math/binpack/binpack.factor | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/extra/math/binpack/binpack.factor b/extra/math/binpack/binpack.factor index f6473f2e25..e3a009feb5 100644 --- a/extra/math/binpack/binpack.factor +++ b/extra/math/binpack/binpack.factor @@ -6,16 +6,17 @@ USING: sequences kernel arrays vectors accessors assocs sorting math math.functi IN: math.binpack : (binpack) ( bins item -- ) - swap dup [ [ second ] map sum ] map swap zip sort-keys values first push ; + [ [ values sum ] map ] keep + zip sort-keys values first push ; : binpack ( assoc n -- bins ) - [ sort-values reverse [ length ] keep swap ] dip - [ / ceiling ] keep swap [ ] map - swap [ dupd (binpack) ] each ; + [ sort-values dup length ] dip + tuck / ceiling [ ] map + tuck [ (binpack) ] curry each ; : binpack* ( items n -- bins ) [ dup zip ] dip binpack [ keys ] map ; : binpack! ( items quot n -- bins ) - [ dup ] 2dip [ map zip ] dip binpack [ keys ] map ; + [ dupd map zip ] dip binpack [ keys ] map ; From 414ddfe2138f6fc7e6c113df73e46353aa1beda0 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Thu, 2 Oct 2008 14:16:53 -0700 Subject: [PATCH 004/150] Fix typo in db-docs. --- basis/db/db-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/db/db-docs.factor b/basis/db/db-docs.factor index b0a01269ab..29a81b3621 100644 --- a/basis/db/db-docs.factor +++ b/basis/db/db-docs.factor @@ -218,7 +218,7 @@ ARTICLE: "db-protocol" "Low-level database protocol" { $subsection db-open } "Closing a database:" { $subsection db-close } -"Creating tatements:" +"Creating statements:" { $subsection } { $subsection } "Using statements with the database:" From 96d6db5b9d2b8f1f9c233e40e1ba79848dd2f11b Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Fri, 3 Oct 2008 21:58:57 -0700 Subject: [PATCH 005/150] Fix copyright in crypto/barrett/tests. --- extra/crypto/barrett/barrett-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/crypto/barrett/barrett-tests.factor b/extra/crypto/barrett/barrett-tests.factor index 01163f730f..13dae69dce 100644 --- a/extra/crypto/barrett/barrett-tests.factor +++ b/extra/crypto/barrett/barrett-tests.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 DoDoug Coleman. +! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: crypto.barrett kernel math namespaces tools.test ; IN: crypto.barrett.tests From 46c3f0def1ca86400df0ce7c82f2ed6ee8ef1a49 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Oct 2008 20:31:48 -0500 Subject: [PATCH 006/150] Remove unused error class --- basis/random/random.factor | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/basis/random/random.factor b/basis/random/random.factor index 8a69b28171..b5f8ac48b8 100644 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -51,13 +51,12 @@ M: sequence random ( seq -- elt ) [ length random-integer ] keep nth ] if-empty ; -ERROR: negative-random n ; M: integer random ( integer -- integer' ) - { - { [ dup 0 = ] [ ] } - { [ dup 0 < ] [ neg random-integer neg ] } - [ random-integer ] - } cond ; + dup sgn { + { 0 [ ] } + { -1 [ neg random-integer neg ] } + { 1 [ random-integer ] } + } case ; : delete-random ( seq -- elt ) [ length random-integer ] keep [ nth ] 2keep delete-nth ; From d5112a0ced6aebdde1cd76e388a1632cb352f1de Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Oct 2008 21:30:29 -0500 Subject: [PATCH 007/150] Working on stack frame cleanup --- basis/compiler/generator/generator.factor | 7 +- .../cpu/ppc/architecture/architecture.factor | 27 ++--- basis/cpu/x86/32/32.factor | 106 ++++++++---------- basis/cpu/x86/64/64.factor | 32 +++--- .../cpu/x86/architecture/architecture.factor | 14 ++- 5 files changed, 88 insertions(+), 98 deletions(-) diff --git a/basis/compiler/generator/generator.factor b/basis/compiler/generator/generator.factor index 0a9885357e..2b398eaeea 100644 --- a/basis/compiler/generator/generator.factor +++ b/basis/compiler/generator/generator.factor @@ -296,16 +296,13 @@ M: #return-recursive generate-node : return-size ( ctype -- n ) #! Amount of space we reserve for a return value. - dup large-struct? [ heap-size ] [ drop 0 ] if ; + dup large-struct? [ heap-size ] [ drop 2 cells ] if ; : alien-stack-frame ( params -- n ) alien-parameters parameter-sizes drop ; : alien-invoke-frame ( params -- n ) - #! Two cells for temporary storage, temp@ and on x86.64, - #! small struct return value unpacking - [ return>> return-size ] [ alien-stack-frame ] bi - + 2 cells + ; + [ return>> return-size ] [ alien-stack-frame ] bi + ; : set-stack-frame ( n -- ) dup [ frame-required ] when* \ stack-frame set ; diff --git a/basis/cpu/ppc/architecture/architecture.factor b/basis/cpu/ppc/architecture/architecture.factor index 80ee1802e1..aab104fa6e 100644 --- a/basis/cpu/ppc/architecture/architecture.factor +++ b/basis/cpu/ppc/architecture/architecture.factor @@ -44,7 +44,7 @@ IN: cpu.ppc.architecture : xt-save ( n -- i ) 2 cells - ; M: ppc stack-frame ( n -- i ) - local@ factor-area-size + 4 cells align ; + local@ factor-area-size + cell + 4 cells align ; M: temp-reg v>operand drop 11 ; @@ -166,11 +166,13 @@ M: float-regs %load-param-reg >r 1 rot local@ r> LF ; M: stack-params %load-param-reg ( stack reg reg-class -- ) drop >r 0 1 rot local@ LWZ 0 1 r> param@ STW ; +: next-param@ ( n -- x ) param@ stack-frame* + ; + M: stack-params %save-param-reg ( stack reg reg-class -- ) #! Funky. Read the parameter from the caller's stack frame. #! This word is used in callbacks drop - 0 1 rot param@ stack-frame* + LWZ + 0 1 rot next-param@ LWZ 0 1 rot local@ STW ; M: ppc %prepare-unbox ( -- ) @@ -197,10 +199,8 @@ M: ppc %unbox-long-long ( n func -- ) M: ppc %unbox-large-struct ( n c-type -- ) ! Value must be in r3 - ! Compute destination address - 4 1 roll local@ ADDI - ! Load struct size - heap-size 5 LI + ! Compute destination address and load struct size + [ 4 1 rot local@ ADDI ] [ heap-size 5 LI ] bi* ! Call the function "to_value_struct" f %alien-invoke ; @@ -218,9 +218,8 @@ M: ppc %box-long-long ( n func -- ) 4 1 rot cell + local@ LWZ ] when* r> f %alien-invoke ; -: temp@ ( m -- n ) stack-frame* factor-area-size - swap - ; - -: struct-return@ ( size n -- n ) [ local@ ] [ temp@ ] ?if ; +: struct-return@ ( size n -- n ) + [ local@ ] [ stack-frame* factor-area-size - swap - ] ?if ; M: ppc %prepare-box-struct ( size -- ) #! Compute target address for value struct return @@ -231,10 +230,8 @@ M: ppc %box-large-struct ( n c-type -- ) #! If n = f, then we're boxing a returned struct heap-size [ swap struct-return@ ] keep - ! Compute destination address - 3 1 roll ADDI - ! Load struct size - 4 LI + ! Compute destination address and load struct size + [ 3 1 rot ADDI ] [ 4 LI ] bi* ! Call the function "box_value_struct" f %alien-invoke ; @@ -256,10 +253,10 @@ M: ppc %alien-callback ( quot -- ) M: ppc %prepare-alien-indirect ( -- ) "unbox_alien" f %alien-invoke - 3 1 cell temp@ STW ; + 3 11 MR ; M: ppc %alien-indirect ( -- ) - 11 1 cell temp@ LWZ (%call) ; + (%call) ; M: ppc %callback-value ( ctype -- ) ! Save top of data stack diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 50d8025b38..1173b9e68e 100644 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -1,13 +1,12 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types arrays cpu.x86.assembler +USING: locals alien.c-types arrays cpu.x86.assembler cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot cpu.architecture kernel kernel.private math namespaces sequences -stack-checker.known-words -compiler.generator.registers compiler.generator.fixup -compiler.generator system layouts combinators -command-line compiler compiler.units io vocabs.loader accessors -init ; +stack-checker.known-words compiler.generator.registers +compiler.generator.fixup compiler.generator system layouts +combinators command-line compiler compiler.units io +vocabs.loader accessors init ; IN: cpu.x86.32 ! We implement the FFI for Linux, OS X and Windows all at once. @@ -18,7 +17,6 @@ IN: cpu.x86.32 M: x86.32 ds-reg ESI ; M: x86.32 rs-reg EDI ; M: x86.32 stack-reg ESP ; -M: x86.32 stack-save-reg EDX ; M: x86.32 temp-reg-1 EAX ; M: x86.32 temp-reg-2 ECX ; @@ -32,15 +30,20 @@ M: x86.32 struct-small-enough? ( size -- ? ) heap-size { 1 2 4 8 } member? os { linux netbsd solaris } member? not and ; +: struct-return@ ( size n -- operand ) + [ next-stack@ ] [ \ stack-frame get swap - stack@ ] ?if ; + ! On x86, parameters are never passed in registers. M: int-regs return-reg drop EAX ; M: int-regs param-regs drop { } ; M: int-regs vregs drop { EAX ECX EDX EBP } ; M: int-regs push-return-reg return-reg PUSH ; -: load/store-int-return ( n reg-class -- src dst ) - return-reg stack-reg rot [+] ; -M: int-regs load-return-reg load/store-int-return MOV ; -M: int-regs store-return-reg load/store-int-return swap MOV ; + +M: int-regs load-return-reg + return-reg swap next-stack@ MOV ; + +M: int-regs store-return-reg + [ stack@ ] [ return-reg ] bi* MOV ; M: float-regs param-regs drop { } ; M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ; @@ -48,14 +51,16 @@ M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ; : FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ; M: float-regs push-return-reg - stack-reg swap reg-size [ SUB stack-reg [] ] keep FSTP ; + stack-reg swap reg-size + [ SUB ] [ [ [] ] dip FSTP ] 2bi ; : FLD ( operand size -- ) 4 = [ FLDS ] [ FLDL ] if ; -: load/store-float-return ( n reg-class -- op size ) - [ stack@ ] [ reg-size ] bi* ; -M: float-regs load-return-reg load/store-float-return FLD ; -M: float-regs store-return-reg load/store-float-return FSTP ; +M: float-regs load-return-reg + [ next-stack@ ] [ reg-size ] bi* FLD ; + +M: float-regs store-return-reg + [ stack@ ] [ reg-size ] bi* FSTP ; : align-sub ( n -- ) dup 16 align swap - ESP swap SUB ; @@ -64,7 +69,8 @@ M: float-regs store-return-reg load/store-float-return FSTP ; 16 align ESP swap ADD ; : with-aligned-stack ( n quot -- ) - swap dup align-sub slip align-add ; inline + [ [ align-sub ] [ call ] bi* ] + [ [ align-add ] [ drop ] bi* ] 2bi ; inline M: x86.32 fixnum>slot@ 1 SHR ; @@ -77,57 +83,40 @@ M: object %load-param-reg 3drop ; M: object %save-param-reg 3drop ; -: box@ ( n reg-class -- stack@ ) - #! Used for callbacks; we want to box the values given to - #! us by the C function caller. Computes stack location of - #! nth parameter; note that we must go back one more stack - #! frame, since %box sets one up to call the one-arg boxer - #! function. The size of this stack frame so far depends on - #! the reg-class of the boxer's arg. - reg-size neg + stack-frame* + 20 + ; - : (%box) ( n reg-class -- ) #! If n is f, push the return register onto the stack; we #! are boxing a return value of a C function. If n is an #! integer, push [ESP+n] on the stack; we are boxing a #! parameter being passed to a callback from C. - over [ [ box@ ] keep [ load-return-reg ] keep ] [ nip ] if - push-return-reg ; + over [ load-return-reg ] [ 2drop ] if ; -M: x86.32 %box ( n reg-class func -- ) - over reg-size [ - >r (%box) r> f %alien-invoke +M:: x86.32 %box ( n reg-class func -- ) + n reg-class (%box) + reg-class reg-size [ + reg-class push-return-reg + func f %alien-invoke ] with-aligned-stack ; : (%box-long-long) ( n -- ) - #! If n is f, push the return registers onto the stack; we - #! are boxing a return value of a C function. If n is an - #! integer, push [ESP+n]:[ESP+n+4] on the stack; we are - #! boxing a parameter being passed to a callback from C. [ - int-regs box@ - EDX over stack@ MOV - EAX swap cell - stack@ MOV - ] when* - EDX PUSH - EAX PUSH ; + EDX over next-stack@ MOV + EAX swap cell - next-stack@ MOV + ] when* ; M: x86.32 %box-long-long ( n func -- ) + [ (%box-long-long) ] dip 8 [ - [ (%box-long-long) ] [ f %alien-invoke ] bi* + EDX PUSH + EAX PUSH + f %alien-invoke ] with-aligned-stack ; -: struct-return@ ( size n -- n ) - [ stack-frame* cell + + ] [ \ stack-frame get swap - ] ?if ; - -M: x86.32 %box-large-struct ( n c-type -- ) +M:: x86.32 %box-large-struct ( n c-type -- ) ! Compute destination address - heap-size - [ swap struct-return@ ] keep - ECX ESP roll [+] LEA + ECX c-type heap-size n struct-return@ LEA 8 [ ! Push struct size - PUSH + c-type heap-size PUSH ! Push destination address ECX PUSH ! Copy the struct from the C stack @@ -136,9 +125,9 @@ M: x86.32 %box-large-struct ( n c-type -- ) M: x86.32 %prepare-box-struct ( size -- ) ! Compute target address for value struct return - EAX ESP rot f struct-return@ [+] LEA + EAX swap f struct-return@ LEA ! Store it as the first parameter - ESP [] EAX MOV ; + 0 stack@ EAX MOV ; M: x86.32 %box-small-struct ( c-type -- ) #! Box a <= 8-byte struct returned in EAX:EDX. OS X only. @@ -207,13 +196,12 @@ M: x86 %unbox-small-struct ( size -- ) } case ; M: x86.32 %unbox-large-struct ( n c-type -- ) - #! Alien must be in EAX. - heap-size + ! Alien must be in EAX. ! Compute destination address - ECX ESP roll [+] LEA + ECX rot stack@ LEA 12 [ ! Push struct size - PUSH + heap-size PUSH ! Push destination address ECX PUSH ! Push source address @@ -224,10 +212,10 @@ M: x86.32 %unbox-large-struct ( n c-type -- ) M: x86.32 %prepare-alien-indirect ( -- ) "unbox_alien" f %alien-invoke - cell temp@ EAX MOV ; + EBP EAX MOV ; M: x86.32 %alien-indirect ( -- ) - cell temp@ CALL ; + EBP CALL ; M: x86.32 %alien-callback ( quot -- ) 4 [ @@ -239,7 +227,7 @@ M: x86.32 %alien-callback ( quot -- ) M: x86.32 %callback-value ( ctype -- ) ! Align C stack ESP 12 SUB - ! Save top of data stack + ! Save top of data stack in non-volatile register %prepare-unbox EAX PUSH ! Restore data/call/retain stacks diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 01b8935e39..8c9762630b 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -12,7 +12,6 @@ IN: cpu.x86.64 M: x86.64 ds-reg R14 ; M: x86.64 rs-reg R15 ; M: x86.64 stack-reg RSP ; -M: x86.64 stack-save-reg RSI ; M: x86.64 temp-reg-1 RAX ; M: x86.64 temp-reg-2 RCX ; @@ -46,7 +45,9 @@ M: stack-params %load-param-reg r> stack@ R11 MOV ; M: stack-params %save-param-reg - >r stack-frame* + cell + swap r> %load-param-reg ; + drop + R11 swap next-stack@ MOV + stack@ R11 MOV ; : with-return-regs ( quot -- ) [ @@ -121,7 +122,7 @@ M: x86.64 %unbox-large-struct ( n c-type -- ) ! Source is in RDI heap-size ! Load destination address - RSI RSP roll [+] LEA + RSI rot stack@ LEA ! Load structure size RDX swap MOV ! Copy the struct to the C stack @@ -145,7 +146,7 @@ M: x86.64 %box-long-long ( n func -- ) M: x86.64 struct-small-enough? ( size -- ? ) heap-size 2 cells <= ; -: box-struct-field@ ( i -- operand ) RSP swap 1+ cells [+] ; +: box-struct-field@ ( i -- operand ) 1+ cells stack@ ; : %box-struct-field ( c-type i -- ) box-struct-field@ swap reg-class>> { @@ -164,21 +165,22 @@ M: x86.64 %box-small-struct ( c-type -- ) ] with-return-regs ; : struct-return@ ( size n -- n ) - [ ] [ \ stack-frame get swap - ] ?if ; + [ ] [ \ stack-frame get swap - ] ?if stack@ ; M: x86.64 %box-large-struct ( n c-type -- ) ! Struct size is parameter 2 heap-size RSI over MOV ! Compute destination address - swap struct-return@ RDI RSP rot [+] LEA + RDI spin struct-return@ LEA ! Copy the struct from the C stack "box_value_struct" f %alien-invoke ; M: x86.64 %prepare-box-struct ( size -- ) - ! Compute target address for value struct return - RAX RSP rot f struct-return@ [+] LEA - RSP 0 [+] RAX MOV ; + ! Compute target address for value struct return, store it + ! as the first parameter + RAX swap f struct-return@ LEA + 0 stack@ RAX MOV ; M: x86.64 %prepare-var-args RAX RAX XOR ; @@ -192,10 +194,10 @@ M: x86.64 %alien-invoke M: x86.64 %prepare-alien-indirect ( -- ) "unbox_alien" f %alien-invoke - cell temp@ RAX MOV ; + RBP RAX MOV ; M: x86.64 %alien-indirect ( -- ) - cell temp@ CALL ; + RBP CALL ; M: x86.64 %alien-callback ( quot -- ) RDI load-indirect "c_to_factor" f %alien-invoke ; @@ -203,12 +205,14 @@ M: x86.64 %alien-callback ( quot -- ) M: x86.64 %callback-value ( ctype -- ) ! Save top of data stack %prepare-unbox - ! Put former top of data stack in RDI - cell temp@ RDI MOV + ! Save top of data stack + RSP 8 SUB + RDI PUSH ! Restore data/call/retain stacks "unnest_stacks" f %alien-invoke ! Put former top of data stack in RDI - RDI cell temp@ MOV + RDI POP + RSP 8 ADD ! Unbox former top of data stack to return registers unbox-return ; diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor index c97552a649..4770400434 100644 --- a/basis/cpu/x86/architecture/architecture.factor +++ b/basis/cpu/x86/architecture/architecture.factor @@ -10,10 +10,16 @@ IN: cpu.x86.architecture HOOK: ds-reg cpu ( -- reg ) HOOK: rs-reg cpu ( -- reg ) HOOK: stack-reg cpu ( -- reg ) -HOOK: stack-save-reg cpu ( -- reg ) : stack@ ( n -- op ) stack-reg swap [+] ; +: next-stack@ ( n -- operand ) + #! nth parameter from the next stack frame. Used to box + #! input values to callbacks; the callback has its own + #! stack frame set up, and we want to read the frame + #! set up by the caller. + stack-frame* + cell + stack@ ; + : reg-stack ( n reg -- op ) swap cells neg [+] ; M: ds-loc v>operand n>> ds-reg reg-stack ; @@ -32,8 +38,8 @@ M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ; M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ; GENERIC: push-return-reg ( reg-class -- ) -GENERIC: load-return-reg ( stack@ reg-class -- ) -GENERIC: store-return-reg ( stack@ reg-class -- ) +GENERIC: load-return-reg ( n reg-class -- ) +GENERIC: store-return-reg ( n reg-class -- ) ! Only used by inline allocation HOOK: temp-reg-1 cpu ( -- reg ) @@ -137,8 +143,6 @@ M: x86 small-enough? ( n -- ? ) : %tag-fixnum ( reg -- ) tag-bits get SHL ; -: temp@ ( n -- op ) stack-reg \ stack-frame get rot - [+] ; - M: x86 %return ( -- ) 0 %unwind ; ! Alien intrinsics From cf135e08b382e63c43f44905492ccc1598457556 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Sun, 5 Oct 2008 22:00:35 -0500 Subject: [PATCH 008/150] Tweak deploy descriptor to speed up tools.deploy test --- basis/tools/deploy/test/6/deploy.factor | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/basis/tools/deploy/test/6/deploy.factor b/basis/tools/deploy/test/6/deploy.factor index 410bb770be..e7d3764d39 100644 --- a/basis/tools/deploy/test/6/deploy.factor +++ b/basis/tools/deploy/test/6/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-threads? f } - { deploy-ui? f } - { deploy-io 1 } - { deploy-c-types? f } - { deploy-name "tools.deploy.test.6" } - { deploy-compiler? t } { deploy-reflection 1 } { deploy-word-props? f } + { deploy-io 1 } + { deploy-name "tools.deploy.test.6" } + { deploy-math? t } + { deploy-random? f } + { deploy-compiler? t } + { deploy-ui? f } + { deploy-c-types? f } { deploy-word-defs? f } { "stop-after-last-window?" t } - { deploy-random? f } - { deploy-math? f } + { deploy-threads? f } } From 66ae62638d74f983d923ba08daef139b64be838c Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Sun, 5 Oct 2008 22:00:52 -0500 Subject: [PATCH 009/150] Fix Windows deployment --- basis/tools/deploy/shaker/shaker.factor | 2 +- basis/tools/deploy/windows/windows.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) mode change 100644 => 100755 basis/tools/deploy/shaker/shaker.factor mode change 100644 => 100755 basis/tools/deploy/windows/windows.factor diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor old mode 100644 new mode 100755 index 7c02e87209..d9348bedd5 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -321,7 +321,7 @@ IN: tools.deploy.shaker ] [ drop ] if ; : strip-c-io ( -- ) - deploy-io get 2 = [ + deploy-io get 2 = os windows? or [ [ c-io-backend forget "io.streams.c" forget-vocab diff --git a/basis/tools/deploy/windows/windows.factor b/basis/tools/deploy/windows/windows.factor old mode 100644 new mode 100755 index ce4fee19d7..ad1b3cbd84 --- a/basis/tools/deploy/windows/windows.factor +++ b/basis/tools/deploy/windows/windows.factor @@ -14,7 +14,7 @@ IN: tools.deploy.windows "resource:freetype6.dll" "resource:zlib1.dll" } swap copy-files-into - ] when ; + ] [ drop ] if ; : create-exe-dir ( vocab bundle-name -- vm ) deploy-ui? get [ From 0cfedcdc8d788064abc544eeea946b41cc8b4fde Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Sun, 5 Oct 2008 22:08:13 -0500 Subject: [PATCH 010/150] Fix deploy size regresson --- basis/random/random-docs.factor | 22 +++++++++++----------- basis/random/random.factor | 15 +++------------ 2 files changed, 14 insertions(+), 23 deletions(-) mode change 100644 => 100755 basis/random/random-docs.factor mode change 100644 => 100755 basis/random/random.factor diff --git a/basis/random/random-docs.factor b/basis/random/random-docs.factor old mode 100644 new mode 100755 index 51656a77dd..18c9ca781c --- a/basis/random/random-docs.factor +++ b/basis/random/random-docs.factor @@ -15,21 +15,18 @@ HELP: random-bytes* { $description "Generates a byte-array of random bytes." } ; HELP: random -{ $values { "obj" object } { "elt" "a random element" } } -{ $description "Outputs a random element of the input object. If the object is an integer, an input of zero always returns a zero, while any other integer integers yield a random integer in the interval between itself and zero, inclusive of zero. On a sequence, an empty sequence always outputs " { $link f } "." } +{ $values { "seq" sequence } { "elt" "a random element" } } +{ $description "Outputs a random element of the input sequence. Outputs " { $link f } " if the sequence is empty." } +{ $notes "Since integers are sequences, passing an integer " { $snippet "n" } " outputs an integer in the interval " { $snippet "[0,n)" } "." } { $examples { $unchecked-example "USING: random prettyprint ;" "10 random ." "3" } - { $example "USING: random prettyprint ;" - "0 random ." - "0" } { $unchecked-example "USING: random prettyprint ;" - "-10 random ." - "-8" } - { $unchecked-example "USING: random prettyprint ;" - "{ \"a\" \"b\" \"c\" } random ." - "\"a\"" } + "SYMBOL: heads" + "SYMBOL: tails" + "{ heads tails } random ." + "heads" } } ; HELP: random-bytes @@ -74,7 +71,10 @@ ARTICLE: "random-protocol" "Random protocol" { $subsection seed-random } ; ARTICLE: "random" "Generating random integers" -"The " { $vocab-link "random" } " vocabulary contains a protocol for generating random or pseudorandom numbers. The ``Mersenne Twister'' pseudorandom number generator algorithm is the default generator stored in " { $link random-generator } "." +"The " { $vocab-link "random" } " vocabulary contains a protocol for generating random or pseudorandom numbers." +$nl +"The ``Mersenne Twister'' pseudorandom number generator algorithm is the default generator stored in " { $link random-generator } "." +$nl "Generate a random object:" { $subsection random } "Combinators to change the random number generator:" diff --git a/basis/random/random.factor b/basis/random/random.factor old mode 100644 new mode 100755 index b5f8ac48b8..845f8e004f --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -33,10 +33,6 @@ M: f random-32* ( obj -- * ) no-random-number-generator ; random-generator get random-bytes* ] keep head ; -GENERIC: random ( obj -- elt ) - -: random-bits ( n -- r ) 2^ random ; - -M: sequence random ( seq -- elt ) +: random-bits ( n -- r ) 2^ random-integer ; + +: random ( seq -- elt ) [ f ] [ [ length random-integer ] keep nth ] if-empty ; -M: integer random ( integer -- integer' ) - dup sgn { - { 0 [ ] } - { -1 [ neg random-integer neg ] } - { 1 [ random-integer ] } - } case ; - : delete-random ( seq -- elt ) [ length random-integer ] keep [ nth ] 2keep delete-nth ; From a5fcb006fbd58d8d0dba442a70495cc33efcc1b4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Oct 2008 22:17:56 -0500 Subject: [PATCH 011/150] Clean up x86 stack frame code a bit more --- basis/cpu/x86/architecture/architecture.factor | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor index 4770400434..ea54ef85af 100644 --- a/basis/cpu/x86/architecture/architecture.factor +++ b/basis/cpu/x86/architecture/architecture.factor @@ -18,7 +18,7 @@ HOOK: stack-reg cpu ( -- reg ) #! input values to callbacks; the callback has its own #! stack frame set up, and we want to read the frame #! set up by the caller. - stack-frame* + cell + stack@ ; + stack-frame* + stack@ ; : reg-stack ( n reg -- op ) swap cells neg [+] ; @@ -52,20 +52,18 @@ HOOK: prepare-division cpu ( -- ) M: immediate load-literal v>operand swap v>operand MOV ; M: x86 stack-frame ( n -- i ) - 3 cells + 16 align cell - ; + 3 cells + 16 align ; M: x86 %save-word-xt ( -- ) temp-reg v>operand 0 MOV rc-absolute-cell rel-this ; -: factor-area-size ( -- n ) 4 cells ; - M: x86 %prologue ( n -- ) - dup cell + PUSH + dup PUSH temp-reg v>operand PUSH - stack-reg swap 2 cells - SUB ; + stack-reg swap 3 cells - SUB ; M: x86 %epilogue ( n -- ) - stack-reg swap ADD ; + stack-reg swap cell - ADD ; HOOK: %alien-global cpu ( symbol dll register -- ) From b0d57ead863995421f0a259294e3c53e5deed5ad Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Oct 2008 23:09:10 -0500 Subject: [PATCH 012/150] Fix unit test --- basis/random/random-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/random/random-tests.factor b/basis/random/random-tests.factor index c6d88c5525..e686dd7301 100644 --- a/basis/random/random-tests.factor +++ b/basis/random/random-tests.factor @@ -16,4 +16,4 @@ IN: random.tests [ t ] [ 1000 [ 400 random ] replicate prune length 256 > ] unit-test -[ 0 ] [ 0 random ] unit-test +[ f ] [ 0 random ] unit-test From 33d775890cfe24d95fc295cfe6da4399b36c25fd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Oct 2008 00:20:00 -0500 Subject: [PATCH 013/150] More stack frame refactoring --- basis/compiler/generator/fixup/fixup.factor | 6 ++-- basis/compiler/generator/generator.factor | 31 +++++++++---------- basis/cpu/architecture/architecture.factor | 13 ++++---- .../cpu/ppc/architecture/architecture.factor | 20 ++++++------ basis/cpu/x86/32/32.factor | 16 +++++----- basis/cpu/x86/64/64.factor | 17 +++++----- .../cpu/x86/architecture/architecture.factor | 20 ++++++++---- 7 files changed, 63 insertions(+), 60 deletions(-) diff --git a/basis/compiler/generator/fixup/fixup.factor b/basis/compiler/generator/fixup/fixup.factor index ecc88a7a5e..e8bdc561b7 100644 --- a/basis/compiler/generator/fixup/fixup.factor +++ b/basis/compiler/generator/fixup/fixup.factor @@ -13,7 +13,7 @@ TUPLE: frame-required n ; : frame-required ( n -- ) \ frame-required boa , ; -: stack-frame-size ( code -- n ) +: compute-stack-frame-size ( code -- n ) no-stack-frame [ dup frame-required? [ n>> max ] [ drop ] if ] reduce ; @@ -37,7 +37,7 @@ M: label fixup* : if-stack-frame ( frame-size quot -- ) swap dup no-stack-frame = - [ 2drop ] [ stack-frame swap call ] if ; inline + [ 2drop ] [ stack-frame-size swap call ] if ; inline M: word fixup* { @@ -146,7 +146,7 @@ SYMBOL: literal-table : fixup ( code -- literals relocation labels code ) [ init-fixup - dup stack-frame-size swap [ fixup* ] each drop + dup compute-stack-frame-size swap [ fixup* ] each drop literal-table get >array relocation-table get >byte-array diff --git a/basis/compiler/generator/generator.factor b/basis/compiler/generator/generator.factor index 2b398eaeea..22de9d3587 100644 --- a/basis/compiler/generator/generator.factor +++ b/basis/compiler/generator/generator.factor @@ -299,18 +299,17 @@ M: #return-recursive generate-node dup large-struct? [ heap-size ] [ drop 2 cells ] if ; : alien-stack-frame ( params -- n ) - alien-parameters parameter-sizes drop ; + stack-frame new + swap + [ return>> return-size >>return ] + [ alien-parameters parameter-sizes drop >>params ] bi + dup [ params>> ] [ return>> ] bi + >>size + dup size>> stack-frame-size >>total-size ; -: alien-invoke-frame ( params -- n ) - [ return>> return-size ] [ alien-stack-frame ] bi + ; - -: set-stack-frame ( n -- ) - dup [ frame-required ] when* \ stack-frame set ; - -: with-stack-frame ( n quot -- ) - swap set-stack-frame +: with-stack-frame ( params quot -- ) + swap alien-stack-frame [ size>> frame-required ] [ stack-frame set ] bi call - f set-stack-frame ; inline + stack-frame off ; inline GENERIC: reg-size ( register-class -- n ) @@ -413,8 +412,8 @@ M: long-long-type flatten-value-type ( type -- types ) #! parameters. If the C function is returning a structure, #! the first parameter is an implicit target area pointer, #! so we need to use a different offset. - return>> dup large-struct? - [ heap-size %prepare-box-struct cell ] [ drop 0 ] if ; + return>> large-struct? + [ %prepare-box-struct cell ] [ 0 ] if ; : objects>registers ( params -- ) #! Generate code for unboxing a list of C types, then @@ -473,7 +472,7 @@ M: no-such-symbol compiler-error-type M: #alien-invoke generate-node params>> - dup alien-invoke-frame [ + dup [ end-basic-block %prepare-alien-invoke dup objects>registers @@ -487,7 +486,7 @@ M: #alien-invoke generate-node ! #alien-indirect M: #alien-indirect generate-node params>> - dup alien-invoke-frame [ + dup [ ! Flush registers end-basic-block ! Save registers for GC @@ -553,7 +552,7 @@ TUPLE: callback-context ; : callback-unwind ( params -- n ) { - { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] } + { [ dup abi>> "stdcall" = ] [ drop stack-frame get params>> ] } { [ dup return>> large-struct? ] [ drop 4 ] } [ drop 0 ] } cond ; @@ -569,7 +568,7 @@ TUPLE: callback-context ; dup xt>> dup [ init-templates %prologue-later - dup alien-stack-frame [ + dup [ [ registers>objects ] [ wrap-callback-quot %alien-callback ] [ %callback-return ] diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 63c52d1025..f22d4a2a90 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays generic kernel kernel.private math memory -namespaces make sequences layouts system hashtables classes -alien byte-arrays combinators words sets ; +USING: accessors arrays generic kernel kernel.private math +memory namespaces make sequences layouts system hashtables +classes alien byte-arrays combinators words sets ; IN: cpu.architecture ! Register classes @@ -33,10 +33,9 @@ GENERIC# load-literal 1 ( obj vreg -- ) HOOK: load-indirect cpu ( obj reg -- ) -HOOK: stack-frame cpu ( frame-size -- n ) +HOOK: stack-frame-size cpu ( frame-size -- n ) -: stack-frame* ( -- n ) - \ stack-frame get stack-frame ; +TUPLE: stack-frame total-size size params return ; ! Set up caller stack frame HOOK: %prologue cpu ( n -- ) @@ -117,7 +116,7 @@ HOOK: %box cpu ( n reg-class func -- ) HOOK: %box-long-long cpu ( n func -- ) -HOOK: %prepare-box-struct cpu ( size -- ) +HOOK: %prepare-box-struct cpu ( -- ) HOOK: %box-small-struct cpu ( c-type -- ) diff --git a/basis/cpu/ppc/architecture/architecture.factor b/basis/cpu/ppc/architecture/architecture.factor index aab104fa6e..357349193e 100644 --- a/basis/cpu/ppc/architecture/architecture.factor +++ b/basis/cpu/ppc/architecture/architecture.factor @@ -43,8 +43,8 @@ IN: cpu.ppc.architecture : xt-save ( n -- i ) 2 cells - ; -M: ppc stack-frame ( n -- i ) - local@ factor-area-size + cell + 4 cells align ; +M: ppc stack-frame-size ( n -- i ) + local@ factor-area-size + 4 cells align ; M: temp-reg v>operand drop 11 ; @@ -166,7 +166,7 @@ M: float-regs %load-param-reg >r 1 rot local@ r> LF ; M: stack-params %load-param-reg ( stack reg reg-class -- ) drop >r 0 1 rot local@ LWZ 0 1 r> param@ STW ; -: next-param@ ( n -- x ) param@ stack-frame* + ; +: next-param@ ( n -- x ) param@ stack-frame get total-size>> + ; M: stack-params %save-param-reg ( stack reg reg-class -- ) #! Funky. Read the parameter from the caller's stack frame. @@ -218,20 +218,18 @@ M: ppc %box-long-long ( n func -- ) 4 1 rot cell + local@ LWZ ] when* r> f %alien-invoke ; -: struct-return@ ( size n -- n ) - [ local@ ] [ stack-frame* factor-area-size - swap - ] ?if ; +: struct-return@ ( n -- n ) + [ stack-frame get params>> ] unless* local@ ; -M: ppc %prepare-box-struct ( size -- ) +M: ppc %prepare-box-struct ( -- ) #! Compute target address for value struct return - 3 1 rot f struct-return@ ADDI + 3 1 f struct-return@ ADDI 3 1 0 local@ STW ; M: ppc %box-large-struct ( n c-type -- ) - #! If n = f, then we're boxing a returned struct - heap-size - [ swap struct-return@ ] keep + ! If n = f, then we're boxing a returned struct ! Compute destination address and load struct size - [ 3 1 rot ADDI ] [ 4 LI ] bi* + [ 3 1 rot struct-return@ ADDI ] [ heap-size 4 LI ] bi* ! Call the function "box_value_struct" f %alien-invoke ; diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 1173b9e68e..dc891a8178 100644 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -30,8 +30,8 @@ M: x86.32 struct-small-enough? ( size -- ? ) heap-size { 1 2 4 8 } member? os { linux netbsd solaris } member? not and ; -: struct-return@ ( size n -- operand ) - [ next-stack@ ] [ \ stack-frame get swap - stack@ ] ?if ; +: struct-return@ ( n -- operand ) + [ next-stack@ ] [ stack-frame get params>> stack@ ] if* ; ! On x86, parameters are never passed in registers. M: int-regs return-reg drop EAX ; @@ -63,10 +63,10 @@ M: float-regs store-return-reg [ stack@ ] [ reg-size ] bi* FSTP ; : align-sub ( n -- ) - dup 16 align swap - ESP swap SUB ; + [ align-stack ] keep - decr-stack-reg ; : align-add ( n -- ) - 16 align ESP swap ADD ; + align-stack incr-stack-reg ; : with-aligned-stack ( n quot -- ) [ [ align-sub ] [ call ] bi* ] @@ -113,7 +113,7 @@ M: x86.32 %box-long-long ( n func -- ) M:: x86.32 %box-large-struct ( n c-type -- ) ! Compute destination address - ECX c-type heap-size n struct-return@ LEA + ECX n struct-return@ LEA 8 [ ! Push struct size c-type heap-size PUSH @@ -123,9 +123,9 @@ M:: x86.32 %box-large-struct ( n c-type -- ) "box_value_struct" f %alien-invoke ] with-aligned-stack ; -M: x86.32 %prepare-box-struct ( size -- ) +M: x86.32 %prepare-box-struct ( -- ) ! Compute target address for value struct return - EAX swap f struct-return@ LEA + EAX f struct-return@ LEA ! Store it as the first parameter 0 stack@ EAX MOV ; @@ -248,7 +248,7 @@ M: x86.32 %cleanup ( alien-node -- ) { { [ dup abi>> "stdcall" = ] - [ alien-stack-frame ESP swap SUB ] + [ drop ESP stack-frame get params>> SUB ] } { [ dup return>> large-struct? ] [ drop EAX PUSH ] diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 8c9762630b..5bcd733eaa 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -164,22 +164,21 @@ M: x86.64 %box-small-struct ( c-type -- ) "box_small_struct" f %alien-invoke ] with-return-regs ; -: struct-return@ ( size n -- n ) - [ ] [ \ stack-frame get swap - ] ?if stack@ ; +: struct-return@ ( n -- operand ) + [ stack-frame get params>> ] unless* stack@ ; M: x86.64 %box-large-struct ( n c-type -- ) ! Struct size is parameter 2 - heap-size - RSI over MOV + RSI swap heap-size MOV ! Compute destination address - RDI spin struct-return@ LEA + RDI swap struct-return@ LEA ! Copy the struct from the C stack "box_value_struct" f %alien-invoke ; -M: x86.64 %prepare-box-struct ( size -- ) - ! Compute target address for value struct return, store it - ! as the first parameter - RAX swap f struct-return@ LEA +M: x86.64 %prepare-box-struct ( -- ) + ! Compute target address for value struct return + RAX f struct-return@ LEA + ! Store it as the first parameter 0 stack@ RAX MOV ; M: x86.64 %prepare-var-args RAX RAX XOR ; diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor index ea54ef85af..d10397de3b 100644 --- a/basis/cpu/x86/architecture/architecture.factor +++ b/basis/cpu/x86/architecture/architecture.factor @@ -18,7 +18,7 @@ HOOK: stack-reg cpu ( -- reg ) #! input values to callbacks; the callback has its own #! stack frame set up, and we want to read the frame #! set up by the caller. - stack-frame* + stack@ ; + stack-frame get total-size>> + stack@ ; : reg-stack ( n reg -- op ) swap cells neg [+] ; @@ -51,19 +51,27 @@ HOOK: prepare-division cpu ( -- ) M: immediate load-literal v>operand swap v>operand MOV ; -M: x86 stack-frame ( n -- i ) - 3 cells + 16 align ; +: align-stack ( n -- n' ) + os macosx? [ 16 align ] when ; + +M: x86 stack-frame-size ( n -- i ) + 3 cells + align-stack ; M: x86 %save-word-xt ( -- ) temp-reg v>operand 0 MOV rc-absolute-cell rel-this ; +: decr-stack-reg ( n -- ) + dup 0 = [ drop ] [ stack-reg swap SUB ] if ; + M: x86 %prologue ( n -- ) dup PUSH temp-reg v>operand PUSH - stack-reg swap 3 cells - SUB ; + 3 cells - decr-stack-reg ; -M: x86 %epilogue ( n -- ) - stack-reg swap cell - ADD ; +: incr-stack-reg ( n -- ) + dup 0 = [ ] [ stack-reg swap ADD ] if ; + +M: x86 %epilogue ( n -- ) cell - incr-stack-reg ; HOOK: %alien-global cpu ( symbol dll register -- ) From 4ca06ae50ff25eb93a5214914645eb1381393969 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Oct 2008 00:20:24 -0500 Subject: [PATCH 014/150] Typo --- basis/cpu/x86/architecture/architecture.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor index d10397de3b..417f90c9f9 100644 --- a/basis/cpu/x86/architecture/architecture.factor +++ b/basis/cpu/x86/architecture/architecture.factor @@ -69,7 +69,7 @@ M: x86 %prologue ( n -- ) 3 cells - decr-stack-reg ; : incr-stack-reg ( n -- ) - dup 0 = [ ] [ stack-reg swap ADD ] if ; + dup 0 = [ drop ] [ stack-reg swap ADD ] if ; M: x86 %epilogue ( n -- ) cell - incr-stack-reg ; From 3c2caf948ae4c58a56d211597c7ab4fa9d284bd2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Oct 2008 00:33:47 -0500 Subject: [PATCH 015/150] 16-align stack on x86-64 --- basis/cpu/x86/architecture/architecture.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor index 417f90c9f9..01256fb4c5 100644 --- a/basis/cpu/x86/architecture/architecture.factor +++ b/basis/cpu/x86/architecture/architecture.factor @@ -52,7 +52,7 @@ HOOK: prepare-division cpu ( -- ) M: immediate load-literal v>operand swap v>operand MOV ; : align-stack ( n -- n' ) - os macosx? [ 16 align ] when ; + os macosx? cpu x86.64? or [ 16 align ] when ; M: x86 stack-frame-size ( n -- i ) 3 cells + align-stack ; From d142b3283772fa54998f4f4c6c709a51d45f6503 Mon Sep 17 00:00:00 2001 From: erg Date: Mon, 6 Oct 2008 14:54:27 -0500 Subject: [PATCH 016/150] cleaner irc.messages --- extra/irc/messages/messages.factor | 168 +++++++++++++++++------------ 1 file changed, 98 insertions(+), 70 deletions(-) diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 882cec5c8d..14c8633f6f 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -4,7 +4,6 @@ USING: kernel fry splitting ascii calendar accessors combinators qualified arrays classes.tuple math.order ; RENAME: join sequences => sjoin EXCLUDE: sequences => join ; -EXCLUDE: inverse => _ ; IN: irc.messages TUPLE: irc-message line prefix command parameters trailing timestamp ; @@ -17,75 +16,99 @@ TUPLE: nick < irc-message ; TUPLE: privmsg < irc-message name ; TUPLE: kick < irc-message channel who ; TUPLE: roomlist < irc-message channel names ; -TUPLE: nick-in-use < irc-message name ; +TUPLE: nick-in-use < irc-message asterisk name ; TUPLE: notice < irc-message type ; TUPLE: mode < irc-message name mode parameter ; TUPLE: names-reply < irc-message who channel ; TUPLE: unhandled < irc-message ; : ( command parameters trailing -- irc-message ) - irc-message new now >>timestamp - [ [ (>>trailing) ] [ (>>parameters) ] [ (>>command) ] tri ] keep ; + irc-message new + now >>timestamp + swap >>trailing + swap >>parameters + swap >>command ; > ( irc-message -- string ) -M: irc-message command-string>> command>> ; -M: ping command-string>> drop "PING" ; -M: join command-string>> drop "JOIN" ; -M: part command-string>> drop "PART" ; -M: quit command-string>> drop "QUIT" ; -M: nick command-string>> drop "NICK" ; -M: privmsg command-string>> drop "PRIVMSG" ; -M: notice command-string>> drop "NOTICE" ; -M: mode command-string>> drop "MODE" ; -M: kick command-string>> drop "KICK" ; +M: irc-message command-string>> ( irc-message -- string ) command>> ; +M: ping command-string>> ( ping -- string ) drop "PING" ; +M: join command-string>> ( join -- string ) drop "JOIN" ; +M: part command-string>> ( part -- string ) drop "PART" ; +M: quit command-string>> ( quit -- string ) drop "QUIT" ; +M: nick command-string>> ( nick -- string ) drop "NICK" ; +M: privmsg command-string>> ( privmsg -- string ) drop "PRIVMSG" ; +M: notice command-string>> ( notice -- string ) drop "NOTICE" ; +M: mode command-string>> ( mode -- string ) drop "MODE" ; +M: kick command-string>> ( kick -- string ) drop "KICK" ; GENERIC: command-parameters>> ( irc-message -- seq ) -M: irc-message command-parameters>> parameters>> ; -M: ping command-parameters>> drop { } ; -M: join command-parameters>> drop { } ; -M: part command-parameters>> channel>> 1array ; -M: quit command-parameters>> drop { } ; -M: nick command-parameters>> drop { } ; -M: privmsg command-parameters>> name>> 1array ; -M: notice command-parameters>> type>> 1array ; -M: kick command-parameters>> [ channel>> ] [ who>> ] bi 2array ; -M: mode command-parameters>> [ name>> ] [ channel>> ] [ mode>> ] tri 3array ; +M: irc-message command-parameters>> ( irc-message -- seq ) parameters>> ; +M: ping command-parameters>> ( ping -- seq ) drop { } ; +M: join command-parameters>> ( join -- seq ) drop { } ; +M: part command-parameters>> ( part -- seq ) channel>> 1array ; +M: quit command-parameters>> ( quit -- seq ) drop { } ; +M: nick command-parameters>> ( nick -- seq ) drop { } ; +M: privmsg command-parameters>> ( privmsg -- seq ) name>> 1array ; +M: notice command-parameters>> ( norice -- seq ) type>> 1array ; +M: kick command-parameters>> ( kick -- seq ) + [ channel>> ] [ who>> ] bi 2array ; +M: mode command-parameters>> ( mode -- seq ) + [ name>> ] [ channel>> ] [ mode>> ] tri 3array ; -GENERIC: (>>command-parameters) ( params irc-message -- ) +GENERIC# >>command-parameters 1 ( irc-message params -- irc-message ) -M: irc-message (>>command-parameters) 2drop ; -M: logged-in (>>command-parameters) [ first ] dip (>>name) ; -M: privmsg (>>command-parameters) [ first ] dip (>>name) ; -M: notice (>>command-parameters) [ first ] dip (>>type) ; -M: part (>>command-parameters) [ first ] dip (>>channel) ; -M: nick-in-use (>>command-parameters) [ second ] dip (>>name) ; -M: kick (>>command-parameters) - [ first2 ] dip [ (>>who) ] [ (>>channel) ] bi ; -M: names-reply (>>command-parameters) - [ [ first ] dip (>>who) ] [ [ third ] dip (>>channel) ] 2bi ; -M: mode (>>command-parameters) - { { [ >r 2array r> ] [ [ (>>mode) ] [ (>>name) ] bi ] } - { [ >r 3array r> ] [ [ (>>parameter) ] [ (>>mode) ] [ (>>name) ] tri ] } - } switch ; +M: irc-message >>command-parameters ( irc-message params -- irc-message ) + drop ; + +M: logged-in >>command-parameters ( part params -- part ) + first >>name ; + +M: privmsg >>command-parameters ( privmsg params -- privmsg ) + first >>name ; + +M: notice >>command-parameters ( notice params -- notice ) + first >>type ; + +M: part >>command-parameters ( part params -- part ) + first >>channel ; + +M: kick >>command-parameters ( kick params -- kick ) + first2 [ >>channel ] [ >>who ] bi* ; + +M: nick-in-use >>command-parameters ( nick-in-use params -- nick-in-use ) + second >>name ; + +M: names-reply >>command-parameters ( names-reply params -- names-reply ) + first3 nip [ >>who ] [ >>channel ] bi* ; + +M: mode >>command-parameters ( mode params -- mode ) + dup length 3 = [ + first3 [ >>name ] [ >>mode ] [ >>parameter ] tri* + ] [ + first2 [ >>name ] [ >>mode ] bi* + ] if ; PRIVATE> GENERIC: irc-message>client-line ( irc-message -- string ) -M: irc-message irc-message>client-line +M: irc-message irc-message>client-line ( irc-message -- string ) [ command-string>> ] [ command-parameters>> " " sjoin ] [ trailing>> [ CHAR: : prefix ] [ "" ] if* ] tri 3array " " sjoin ; GENERIC: irc-message>server-line ( irc-message -- string ) -M: irc-message irc-message>server-line drop "not implemented yet" ; + +M: irc-message irc-message>server-line ( irc-message -- string ) + drop "not implemented yet" ; server-line drop "not implemented yet" ; : split-at-first ( seq separators -- before after ) dupd '[ _ member? ] find [ cut 1 tail ] [ swap ] if ; -: remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ; +: remove-heading-: ( seq -- seq ) + ":" ?head drop ; : parse-name ( string -- string ) remove-heading-: "!" split-at-first drop ; : split-prefix ( string -- string/f string ) dup ":" head? - [ remove-heading-: " " split1 ] - [ f swap ] - if ; + [ remove-heading-: " " split1 ] [ f swap ] if ; : split-trailing ( string -- string string/f ) ":" split1 ; -: copy-message-in ( origin dest -- ) - { [ [ parameters>> ] dip [ (>>command-parameters) ] [ (>>parameters) ] 2bi ] - [ [ line>> ] dip (>>line) ] - [ [ prefix>> ] dip (>>prefix) ] - [ [ command>> ] dip (>>command) ] - [ [ trailing>> ] dip (>>trailing) ] - [ [ timestamp>> ] dip (>>timestamp) ] - } 2cleave ; +: copy-message-in ( command irc-message -- command ) + { + [ parameters>> [ >>parameters ] [ >>command-parameters ] bi ] + [ line>> >>line ] + [ prefix>> >>prefix ] + [ command>> >>command ] + [ trailing>> >>trailing ] + [ timestamp>> >>timestamp ] + } cleave ; PRIVATE> UNION: sender-in-prefix privmsg join part quit kick mode nick ; GENERIC: irc-message-sender ( irc-message -- sender ) -M: sender-in-prefix irc-message-sender prefix>> parse-name ; +M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender ) + prefix>> parse-name ; : string>irc-message ( string -- object ) dup split-prefix split-trailing [ [ blank? ] trim " " split unclip swap ] dip now irc-message boa ; +: irc-message>command ( irc-message -- command ) + [ + command>> { + { "PING" [ ping ] } + { "NOTICE" [ notice ] } + { "001" [ logged-in ] } + { "433" [ nick-in-use ] } + { "353" [ names-reply ] } + { "JOIN" [ join ] } + { "PART" [ part ] } + { "NICK" [ nick ] } + { "PRIVMSG" [ privmsg ] } + { "QUIT" [ quit ] } + { "MODE" [ mode ] } + { "KICK" [ kick ] } + [ drop unhandled ] + } case new + ] keep copy-message-in ; + : parse-irc-line ( string -- message ) - string>irc-message - dup command>> { - { "PING" [ ping ] } - { "NOTICE" [ notice ] } - { "001" [ logged-in ] } - { "433" [ nick-in-use ] } - { "353" [ names-reply ] } - { "JOIN" [ join ] } - { "PART" [ part ] } - { "NICK" [ nick ] } - { "PRIVMSG" [ privmsg ] } - { "QUIT" [ quit ] } - { "MODE" [ mode ] } - { "KICK" [ kick ] } - [ drop unhandled ] - } case new [ copy-message-in ] keep ; + string>irc-message irc-message>command ; From e42a2d8825a7a280a11610ca9910de643576654d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 15:01:01 -0500 Subject: [PATCH 017/150] clean up constructor --- extra/irc/client/client.factor | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index d40c7d400d..463e35f415 100755 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -19,9 +19,16 @@ C: irc-profile TUPLE: irc-client profile stream in-messages out-messages chats is-running nick connect reconnect-time is-ready ; + : ( profile -- irc-client ) - [ f H{ } clone f ] keep nickname>> - [ latin1 ] 15 seconds f irc-client boa ; + irc-client new + swap >>profile + >>in-messages + >>out-messages + H{ } clone >>chats + dup profile>> nickname>> >>nick + [ latin1 ] >>connect + 15 seconds >>reconnect-time ; TUPLE: irc-chat in-messages client ; TUPLE: irc-server-chat < irc-chat ; From 03043a7cfdba7ee943c5adadd210e3cbb83ca1e7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 15:25:17 -0500 Subject: [PATCH 018/150] remove slot --- extra/irc/messages/messages.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 14c8633f6f..32533c102a 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -16,7 +16,7 @@ TUPLE: nick < irc-message ; TUPLE: privmsg < irc-message name ; TUPLE: kick < irc-message channel who ; TUPLE: roomlist < irc-message channel names ; -TUPLE: nick-in-use < irc-message asterisk name ; +TUPLE: nick-in-use < irc-message name ; TUPLE: notice < irc-message type ; TUPLE: mode < irc-message name mode parameter ; TUPLE: names-reply < irc-message who channel ; From a0a17646c5e4f4b16be73556570336d6dfc346fd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 15:56:54 -0500 Subject: [PATCH 019/150] dettach -> detach (spelling), fix docs --- extra/irc/client/client-docs.factor | 10 +++++----- extra/irc/client/client.factor | 2 +- extra/irc/ui/ui.factor | 2 +- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/extra/irc/client/client-docs.factor b/extra/irc/client/client-docs.factor index 1b9204c4f1..6d4fae9b83 100644 --- a/extra/irc/client/client-docs.factor +++ b/extra/irc/client/client-docs.factor @@ -19,8 +19,8 @@ HELP: attach-chat "Chatting with irc channels/users/etc" { $values { "irc-chat" "an irc chat object" } { "irc-client" "an irc client object" } } { $description "Registers " { $snippet "irc-chat" } " with " { $snippet "irc-client" } " and starts listening." } ; -HELP: dettach-chat "Stop an unregister chat" -{ $values { "irc-chat" "an irc chat object" } { "irc-client" "an irc client object" } } +HELP: detach-chat "Stop an unregister chat" +{ $values { "irc-chat" "an irc chat object" } } { $description "Unregisters " { $snippet "irc-chat" } " from " { $snippet "irc-client" } " and stops listening. This is how you part from a channel." } ; HELP: terminate-irc "Terminates an irc client" @@ -49,7 +49,7 @@ ARTICLE: "irc.client" "IRC Client" { $subsection connect-irc } { $subsection terminate-irc } { $subsection attach-chat } -{ $subsection dettach-chat } +{ $subsection detach-chat } { $subsection hear } { $subsection speak } { $heading "IRC messages" } @@ -72,7 +72,7 @@ ARTICLE: "irc.client" "IRC Client" { $heading "Special messages" } "Some special messages that are created by the library and not by the irc server." { $table - { { $link irc-chat-end } "sent to a chat when it has been dettached from the client, the chat should stop after it receives this message. " } + { { $link irc-chat-end } "sent to a chat when it has been detached from the client, the chat should stop after it receives this message. " } { { $link irc-end } " sent when the client isn't running anymore, chats should stop after it receives this message." } { { $link irc-disconnected } " sent to notify chats that connection was lost." } { { $link irc-connected } " sent to notify chats that a connection with the irc server was established." } } @@ -97,4 +97,4 @@ ARTICLE: "irc.client" "IRC Client" } ; -ABOUT: "irc.client" \ No newline at end of file +ABOUT: "irc.client" diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 463e35f415..ce7a6e5373 100755 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -362,7 +362,7 @@ PRIVATE> : attach-chat ( irc-chat irc-client -- ) [ (attach-chat) ] with-irc-client ; -: dettach-chat ( irc-chat -- ) +: detach-chat ( irc-chat -- ) [ client>> ] keep '[ _ (remove-chat) ] with-irc-client ; : speak ( message irc-chat -- ) diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index 50dc9378a2..e854d285b7 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -186,7 +186,7 @@ M: irc-tab graft* [ chat>> ] [ window>> client>> ] bi attach-chat ; M: irc-tab ungraft* - chat>> dettach-chat ; + chat>> detach-chat ; TUPLE: irc-channel-tab < irc-tab userlist ; From e0d6aadc8e7c8af2819907f4156f9dd7db7528fc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 17:17:14 -0500 Subject: [PATCH 020/150] complete file-info across *bsd, linux --- basis/io/unix/files/files.factor | 71 +++++++++++++++------- basis/io/unix/files/freebsd/freebsd.factor | 17 ++++++ basis/io/unix/files/freebsd/tags.txt | 1 + basis/io/unix/files/macosx/macosx.factor | 16 +++++ basis/io/unix/files/macosx/tags.txt | 1 + basis/io/unix/files/netbsd/netbsd.factor | 17 ++++++ basis/io/unix/files/netbsd/tags.txt | 1 + basis/io/unix/files/openbsd/openbsd.factor | 17 ++++++ basis/io/unix/files/openbsd/tags.txt | 1 + basis/io/unix/files/unique/unique.factor | 2 + 10 files changed, 123 insertions(+), 21 deletions(-) create mode 100644 basis/io/unix/files/freebsd/freebsd.factor create mode 100644 basis/io/unix/files/freebsd/tags.txt create mode 100644 basis/io/unix/files/macosx/macosx.factor create mode 100644 basis/io/unix/files/macosx/tags.txt create mode 100644 basis/io/unix/files/netbsd/netbsd.factor create mode 100644 basis/io/unix/files/netbsd/tags.txt create mode 100644 basis/io/unix/files/openbsd/openbsd.factor create mode 100644 basis/io/unix/files/openbsd/tags.txt diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor index c6eda50855..4319b6c8de 100644 --- a/basis/io/unix/files/files.factor +++ b/basis/io/unix/files/files.factor @@ -4,7 +4,7 @@ USING: io.backend io.ports io.unix.backend io.files io unix unix.stat unix.time kernel math continuations math.bitwise byte-arrays alien combinators calendar io.encodings.binary accessors sequences strings system -io.files.private destructors ; +io.files.private destructors vocabs.loader ; IN: io.unix.files @@ -74,26 +74,14 @@ M: unix copy-file ( from to -- ) [ swap file-info permissions>> chmod io-error ] 2bi ; -: stat>type ( stat -- type ) - stat-st_mode S_IFMT bitand { - { S_IFREG [ +regular-file+ ] } - { S_IFDIR [ +directory+ ] } - { S_IFCHR [ +character-device+ ] } - { S_IFBLK [ +block-device+ ] } - { S_IFIFO [ +fifo+ ] } - { S_IFLNK [ +symbolic-link+ ] } - { S_IFSOCK [ +socket+ ] } - [ drop +unknown+ ] - } case ; +HOOK: stat>file-info os ( stat -- file-info ) -: stat>file-info ( stat -- info ) - { - [ stat>type ] - [ stat-st_size ] - [ stat-st_mode ] - [ stat-st_mtim timespec-sec seconds unix-1970 time+ ] - } cleave - \ file-info boa ; +HOOK: stat>type os ( stat -- file-info ) + +HOOK: new-file-info os ( -- class ) + +TUPLE: unix-file-info < file-info uid gid dev ino +nlink rdev blocks blocksize ; M: unix file-info ( path -- info ) normalize-path file-status stat>file-info ; @@ -105,4 +93,45 @@ M: unix make-link ( path1 path2 -- ) normalize-path symlink io-error ; M: unix read-link ( path -- path' ) - normalize-path read-symbolic-link ; \ No newline at end of file + normalize-path read-symbolic-link ; + +M: unix new-file-info ( -- class ) unix-file-info new ; + +M: unix stat>file-info ( stat -- file-info ) + [ new-file-info ] dip + { + [ stat>type >>type ] + [ stat-st_size >>size ] + [ stat-st_mode >>permissions ] + [ stat-st_ctim timespec>unix-time >>created ] + [ stat-st_mtim timespec>unix-time >>modified ] + [ stat-st_atim timespec>unix-time >>accessed ] + [ stat-st_uid >>uid ] + [ stat-st_gid >>gid ] + [ stat-st_dev >>dev ] + [ stat-st_ino >>ino ] + [ stat-st_nlink >>nlink ] + [ stat-st_rdev >>rdev ] + [ stat-st_blocks >>blocks ] + [ stat-st_blksize >>blocksize ] + } cleave ; + +M: unix stat>type ( stat -- type ) + stat-st_mode S_IFMT bitand { + { S_IFREG [ +regular-file+ ] } + { S_IFDIR [ +directory+ ] } + { S_IFCHR [ +character-device+ ] } + { S_IFBLK [ +block-device+ ] } + { S_IFIFO [ +fifo+ ] } + { S_IFLNK [ +symbolic-link+ ] } + { S_IFSOCK [ +socket+ ] } + [ drop +unknown+ ] + } case ; + +! Linux has no extra fields in its stat struct +os { + { macosx [ "io.unix.files.macosx" require ] } + { freebsd [ "io.unix.files.freebsd" require ] } + { netbsd [ "io.unix.files.netbsd" require ] } + { openbsd [ "io.unix.files.openbsd" require ] } +} case diff --git a/basis/io/unix/files/freebsd/freebsd.factor b/basis/io/unix/files/freebsd/freebsd.factor new file mode 100644 index 0000000000..14d15bc93d --- /dev/null +++ b/basis/io/unix/files/freebsd/freebsd.factor @@ -0,0 +1,17 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel alien.syntax math io.unix.files system +unix.stat accessors combinators calendar ; +IN: io.unix.files.freebsd + +TUPLE: freebsd-file-info < unix-file-info birth-time flags gen ; + +M: freebsd new-file-info ( -- class ) freebsd-file-info new ; + +M: freebsd stat>file-info ( stat -- file-info ) + [ call-next-method ] keep + { + [ stat-st_flags >>flags ] + [ stat-st_gen >>gen ] + [ stat-st_birthtimepsec timespec>timestamp >>birth-time ] + } cleave ; diff --git a/basis/io/unix/files/freebsd/tags.txt b/basis/io/unix/files/freebsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/files/freebsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/files/macosx/macosx.factor b/basis/io/unix/files/macosx/macosx.factor new file mode 100644 index 0000000000..4173123e45 --- /dev/null +++ b/basis/io/unix/files/macosx/macosx.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel alien.syntax math io.unix.files system +unix.stat accessors combinators ; +IN: io.unix.files.macosx + +TUPLE: macosx-file-info < unix-file-info flags gen ; + +M: macosx new-file-info ( -- class ) macosx-file-info new ; + +M: macosx stat>file-info ( stat -- file-info ) + [ call-next-method ] keep + { + [ stat-st_flags >>flags ] + [ stat-st_gen >>gen ] + } cleave ; diff --git a/basis/io/unix/files/macosx/tags.txt b/basis/io/unix/files/macosx/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/files/macosx/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/files/netbsd/netbsd.factor b/basis/io/unix/files/netbsd/netbsd.factor new file mode 100644 index 0000000000..c61304c128 --- /dev/null +++ b/basis/io/unix/files/netbsd/netbsd.factor @@ -0,0 +1,17 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel alien.syntax math io.unix.files system +unix.stat accessors combinators calendar ; +IN: io.unix.files.netbsd + +TUPLE: netbsd-file-info < unix-file-info birth-time flags gen ; + +M: netbsd new-file-info ( -- class ) netbsd-file-info new ; + +M: netbsd stat>file-info ( stat -- file-info ) + [ call-next-method ] keep + { + [ stat-st_flags >>flags ] + [ stat-st_gen >>gen ] + [ stat-st_birthtim timespec>timestamp >>birth-time ] + } cleave ; diff --git a/basis/io/unix/files/netbsd/tags.txt b/basis/io/unix/files/netbsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/files/netbsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/files/openbsd/openbsd.factor b/basis/io/unix/files/openbsd/openbsd.factor new file mode 100644 index 0000000000..e1473eed4d --- /dev/null +++ b/basis/io/unix/files/openbsd/openbsd.factor @@ -0,0 +1,17 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel alien.syntax math io.unix.files system +unix.stat accessors combinators calendar ; +IN: io.unix.files.openbsd + +TUPLE: openbsd-file-info < unix-file-info birth-time flags gen ; + +M: openbsd new-file-info ( -- class ) openbsd-file-info new ; + +M: openbsd stat>file-info ( stat -- file-info ) + [ call-next-method ] keep + { + [ stat-st_flags >>flags ] + [ stat-st_gen >>gen ] + [ stat-st_birthtim timespec>timestamp >>birth-time ] + } cleave ; diff --git a/basis/io/unix/files/openbsd/tags.txt b/basis/io/unix/files/openbsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/files/openbsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/files/unique/unique.factor b/basis/io/unix/files/unique/unique.factor index 95e321fd93..e47ac6a2e3 100644 --- a/basis/io/unix/files/unique/unique.factor +++ b/basis/io/unix/files/unique/unique.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: kernel io.ports io.unix.backend math.bitwise unix io.files.unique.backend system ; IN: io.unix.files.unique From b168d75a46747ccc64f45dc18ee02b0f6d6c1825 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 17:17:49 -0500 Subject: [PATCH 021/150] add timespec>timestamp word --- basis/calendar/calendar.factor | 9 ++++++++- basis/structs/structs.factor | 10 ++++++++++ basis/unix/time/time.factor | 12 ------------ 3 files changed, 18 insertions(+), 13 deletions(-) diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index 31c835aada..8a27a46aa2 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -402,9 +402,16 @@ PRIVATE> : time-since-midnight ( timestamp -- duration ) dup midnight time- ; +: since-1970 ( time -- timestamp ) + unix-1970 time+ >local-time ; + : timeval>unix-time ( timeval -- timestamp ) [ timeval-sec seconds ] [ timeval-usec microseconds ] bi - time+ unix-1970 time+ >local-time ; + time+ since-1970 ; + +: timespec>unix-time ( timeval -- timestamp ) + [ timespec-sec seconds ] [ timespec-nsec nanoseconds ] bi + time+ since-1970 ; M: timestamp sleep-until timestamp>millis sleep-until ; diff --git a/basis/structs/structs.factor b/basis/structs/structs.factor index f54917dc47..51ac517af3 100644 --- a/basis/structs/structs.factor +++ b/basis/structs/structs.factor @@ -10,3 +10,13 @@ C-STRUCT: timeval "timeval" [ set-timeval-usec ] keep [ set-timeval-sec ] keep ; + +C-STRUCT: timespec + { "time_t" "sec" } + { "long" "nsec" } ; + +: make-timespec ( ms -- timespec ) + 1000 /mod 1000000 * + "timespec" + [ set-timespec-nsec ] keep + [ set-timespec-sec ] keep ; diff --git a/basis/unix/time/time.factor b/basis/unix/time/time.factor index 4fbb20dca0..26b42ddfe7 100644 --- a/basis/unix/time/time.factor +++ b/basis/unix/time/time.factor @@ -1,6 +1,4 @@ - USING: kernel alien.syntax alien.c-types math ; - IN: unix.time TYPEDEF: uint time_t @@ -18,16 +16,6 @@ C-STRUCT: tm { "long" "gmtoff" } ! Seconds: 0-59 (K&R says 0-61?) { "char*" "zone" } ; -C-STRUCT: timespec - { "time_t" "sec" } - { "long" "nsec" } ; - -: make-timespec ( ms -- timespec ) - 1000 /mod 1000000 * - "timespec" - [ set-timespec-nsec ] keep - [ set-timespec-sec ] keep ; - FUNCTION: time_t time ( time_t* t ) ; FUNCTION: tm* localtime ( time_t* clock ) ; FUNCTION: int gettimeofday ( timespec* TP, void* TZP ) ; From 9459eaab4b81c1a9f060393c2cef594b72873523 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 17:28:11 -0500 Subject: [PATCH 022/150] all platforms support the file-info structure --- core/io/files/files.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 1634b7a3f1..bc84aa5d21 100644 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -153,7 +153,7 @@ PRIVATE> "." last-split1 nip ; ! File info -TUPLE: file-info type size permissions modified ; +TUPLE: file-info type size permissions created modified accessed ; HOOK: file-info io-backend ( path -- info ) From 0294308c4c40e3ed49f446b1e45e5e1370bd008e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 17:28:42 -0500 Subject: [PATCH 023/150] work on windows file-info --- basis/io/windows/files/files.factor | 41 ++++++++++++++++++----------- 1 file changed, 25 insertions(+), 16 deletions(-) diff --git a/basis/io/windows/files/files.factor b/basis/io/windows/files/files.factor index 40e7e17402..f4bb3c71dc 100644 --- a/basis/io/windows/files/files.factor +++ b/basis/io/windows/files/files.factor @@ -147,18 +147,18 @@ SYMBOLS: +read-only+ +hidden+ +system+ FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ; : WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info ) + [ file-info new ] dip { - [ WIN32_FIND_DATA-dwFileAttributes win32-file-type ] + [ WIN32_FIND_DATA-dwFileAttributes win32-file-type >>type ] [ [ WIN32_FIND_DATA-nFileSizeLow ] - [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit + [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit >>size ] - [ WIN32_FIND_DATA-dwFileAttributes ] - ! [ WIN32_FIND_DATA-ftCreationTime FILETIME>timestamp ] - [ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp ] - ! [ WIN32_FIND_DATA-ftLastAccessTime FILETIME>timestamp ] - } cleave - \ file-info boa ; + [ WIN32_FIND_DATA-dwFileAttributes >>mode ] + [ WIN32_FIND_DATA-ftCreationTime FILETIME>timestamp >>created ] + [ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp >>modified ] + [ WIN32_FIND_DATA-ftLastAccessTime FILETIME>timestamp >>accessed ] + } cleave ; : find-first-file-stat ( path -- WIN32_FIND_DATA ) "WIN32_FIND_DATA" [ @@ -168,23 +168,32 @@ SYMBOLS: +read-only+ +hidden+ +system+ ] keep ; : BY_HANDLE_FILE_INFORMATION>file-info ( HANDLE_FILE_INFORMATION -- file-info ) + [ file-info new ] dip { - [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type ] + [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type >>type ] [ [ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ] - [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit + [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit >>size + ] + [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes >>mode ] + [ + BY_HANDLE_FILE_INFORMATION-ftCreationTime + FILETIME>timestamp >>created + ] + [ + BY_HANDLE_FILE_INFORMATION-ftLastWriteTime + FILETIME>timestamp >>modified + ] + [ + BY_HANDLE_FILE_INFORMATION-ftLastAccessTime + FILETIME>timestamp >>accessed ] - [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes ] - ! [ BY_HANDLE_FILE_INFORMATION-ftCreationTime FILETIME>timestamp ] - [ BY_HANDLE_FILE_INFORMATION-ftLastWriteTime FILETIME>timestamp ] - ! [ BY_HANDLE_FILE_INFORMATION-ftLastAccessTime FILETIME>timestamp ] ! [ BY_HANDLE_FILE_INFORMATION-nNumberOfLinks ] ! [ ! [ BY_HANDLE_FILE_INFORMATION-nFileIndexLow ] ! [ BY_HANDLE_FILE_INFORMATION-nFileIndexHigh ] bi >64bit ! ] - } cleave - \ file-info boa ; + } cleave ; : get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION ) [ From 847205432fe1d234f028aa6f2527d8713f17c4de Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 17:34:58 -0500 Subject: [PATCH 024/150] fix load error --- basis/structs/structs.factor | 2 +- basis/unix/time/time.factor | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/structs/structs.factor b/basis/structs/structs.factor index 51ac517af3..6aef757eb4 100644 --- a/basis/structs/structs.factor +++ b/basis/structs/structs.factor @@ -1,4 +1,4 @@ -USING: alien.c-types alien.syntax kernel math ; +USING: alien.c-types alien.syntax kernel math unix.types ; IN: structs C-STRUCT: timeval diff --git a/basis/unix/time/time.factor b/basis/unix/time/time.factor index 26b42ddfe7..67611ae193 100644 --- a/basis/unix/time/time.factor +++ b/basis/unix/time/time.factor @@ -1,8 +1,8 @@ -USING: kernel alien.syntax alien.c-types math ; +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel alien.syntax alien.c-types math unix.types ; IN: unix.time -TYPEDEF: uint time_t - C-STRUCT: tm { "int" "sec" } ! Seconds: 0-59 (K&R says 0-61?) { "int" "min" } ! Minutes: 0-59 From 15f15d4553083bb06909c97e16eeac906849357a Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Thu, 9 Oct 2008 13:23:43 -0700 Subject: [PATCH 025/150] Adding strftime library. --- extra/time/authors.txt | 1 + extra/time/time-docs.factor | 43 ++++++++++++++++++++++++ extra/time/time-tests.factor | 24 ++++++++++++++ extra/time/time.factor | 63 ++++++++++++++++++++++++++++++++++++ 4 files changed, 131 insertions(+) create mode 100644 extra/time/authors.txt create mode 100644 extra/time/time-docs.factor create mode 100644 extra/time/time-tests.factor create mode 100644 extra/time/time.factor diff --git a/extra/time/authors.txt b/extra/time/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/extra/time/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/extra/time/time-docs.factor b/extra/time/time-docs.factor new file mode 100644 index 0000000000..b0ca12e9c6 --- /dev/null +++ b/extra/time/time-docs.factor @@ -0,0 +1,43 @@ + +USING: help.syntax help.markup kernel prettyprint sequences strings ; + +IN: time + +HELP: strftime +{ $values { "format-string" string } } +{ $description "Writes the timestamp (specified on the stack) formatted according to the format string." } +; + +ARTICLE: "strftime" "Formatted timestamps" +"The " { $vocab-link "time" } " vocabulary is used for formatted timestamps.\n" +{ $subsection strftime } +"\n" +"Several format specifications exist for handling arguments of different types, and specifying attributes for the result string, including such things as maximum width, padding, and decimals.\n" +{ $table + { "%a" "Abbreviated weekday name." } + { "%A" "Full weekday name." } + { "%b" "Abbreviated month name." } + { "%B" "Full month name." } + { "%c" "Date and time representation." } + { "%d" "Day of the month as a decimal number [01,31]." } + { "%H" "Hour (24-hour clock) as a decimal number [00,23]." } + { "%I" "Hour (12-hour clock) as a decimal number [01,12]." } + { "%j" "Day of the year as a decimal number [001,366]." } + { "%m" "Month as a decimal number [01,12]." } + { "%M" "Minute as a decimal number [00,59]." } + { "%p" "Either AM or PM." } + { "%S" "Second as a decimal number [00,59]." } + { "%U" "Week number of the year (Sunday as the first day of the week) as a decimal numberb [00,53]." } + { "%w" "Weekday as a decimal number [0(Sunday),6]." } + { "%W" "Week number of the year (Monday as the first day of the week) as a decimal numberb [00,53]." } + { "%x" "Date representation." } + { "%X" "Time representation." } + { "%y" "Year without century as a decimal number [00,99]." } + { "%Y" "Year with century as a decimal number." } + { "%Z" "Time zone name (no characters if no time zone exists)." } + { "%%" "A literal '%' character." } +} ; + +ABOUT: "strftime" + + diff --git a/extra/time/time-tests.factor b/extra/time/time-tests.factor new file mode 100644 index 0000000000..0b0602bd62 --- /dev/null +++ b/extra/time/time-tests.factor @@ -0,0 +1,24 @@ +! Copyright (C) 2008 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: kernel time tools.test calendar ; + +IN: time.tests + +[ "%H:%M:%S" strftime ] must-infer + +: testtime ( -- timestamp ) + 2008 10 9 12 3 15 instant ; + +[ t ] [ "12:03:15" testtime "%H:%M:%S" strftime = ] unit-test +[ t ] [ "12:03:15" testtime "%X" strftime = ] unit-test + +[ t ] [ "10/09/2008" testtime "%m/%d/%Y" strftime = ] unit-test +[ t ] [ "10/09/2008" testtime "%x" strftime = ] unit-test + +[ t ] [ "Thu" testtime "%a" strftime = ] unit-test +[ t ] [ "Thursday" testtime "%A" strftime = ] unit-test + +[ t ] [ "Oct" testtime "%b" strftime = ] unit-test +[ t ] [ "October" testtime "%B" strftime = ] unit-test + diff --git a/extra/time/time.factor b/extra/time/time.factor new file mode 100644 index 0000000000..e609bf381b --- /dev/null +++ b/extra/time/time.factor @@ -0,0 +1,63 @@ +! Copyright (C) 2008 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: accessors arrays calendar io kernel fry macros math +math.functions math.parser peg.ebnf sequences strings vectors ; + +IN: time + +: timestring ( timestamp -- string ) + [ hour>> ] keep [ minute>> ] keep second>> 3array + [ number>string 2 CHAR: 0 pad-left ] map ":" join ; inline + +: datestring ( timestamp -- string ) + [ month>> ] keep [ day>> ] keep year>> 3array + [ number>string 2 CHAR: 0 pad-left ] map "/" join ; inline + + [[ [ "%" ] ]] +fmt-a = "a" => [[ [ dup day-of-week day-abbreviation3 ] ]] +fmt-A = "A" => [[ [ dup day-of-week day-name ] ]] +fmt-b = "b" => [[ [ dup month>> month-abbreviation ] ]] +fmt-B = "B" => [[ [ dup month>> month-name ] ]] +fmt-c = "c" => [[ [ "Not yet implemented" throw ] ]] +fmt-d = "d" => [[ [ dup day>> number>string 2 CHAR: 0 pad-left ] ]] +fmt-H = "H" => [[ [ dup hour>> number>string 2 CHAR: 0 pad-left ] ]] +fmt-I = "I" => [[ [ dup hour>> 12 > [ 12 - ] when number>string 2 CHAR: 0 pad-left ] ]] +fmt-j = "j" => [[ [ dup day-of-year number>string ] ]] +fmt-m = "m" => [[ [ dup month>> number>string 2 CHAR: 0 pad-left ] ]] +fmt-M = "M" => [[ [ dup minute>> number>string 2 CHAR: 0 pad-left ] ]] +fmt-p = "p" => [[ [ dup hour>> 12 < [ "AM" ] [ "PM" ] ? ] ]] +fmt-S = "S" => [[ [ dup second>> round number>string 2 CHAR: 0 pad-left ] ]] +fmt-U = "U" => [[ [ "Not yet implemented" throw ] ]] +fmt-w = "w" => [[ [ dup day-of-week number>string ] ]] +fmt-W = "W" => [[ [ "Not yet implemented" throw ] ]] +fmt-x = "x" => [[ [ dup datestring ] ]] +fmt-X = "X" => [[ [ dup timestring ] ]] +fmt-y = "y" => [[ [ dup year>> 100 mod number>string ] ]] +fmt-Y = "Y" => [[ [ dup year>> number>string ] ]] +fmt-Z = "Z" => [[ [ "Not yet implemented" throw ] ]] +unknown = (.)* => [[ "Unknown directive" throw ]] + +formats_ = fmt-%|fmt-a|fmt-A|fmt-b|fmt-B|fmt-c|fmt-d|fmt-H|fmt-I| + fmt-j|fmt-m|fmt-M|fmt-p|fmt-S|fmt-U|fmt-w|fmt-W|fmt-x| + fmt-X|fmt-y|fmt-Y|fmt-Z|unknown + +formats = "%" (formats_) => [[ second '[ _ dip ] ]] + +plain-text = (!("%").)+ => [[ >string '[ _ swap ] ]] + +text = (formats|plain-text)* => [[ reverse [ [ [ push ] keep ] append ] map ]] + +;EBNF + +PRIVATE> + +MACRO: strftime ( format-string -- ) + parse-format-string [ length ] keep [ ] join + '[ _ @ reverse concat nip ] ; + + From 6d2ade1173da8e7a65d0cf431d1893296f10c98b Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Thu, 9 Oct 2008 19:48:05 -0700 Subject: [PATCH 026/150] Adding week-of-year words. --- extra/time/time.factor | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/extra/time/time.factor b/extra/time/time.factor index e609bf381b..d0411bd5bf 100644 --- a/extra/time/time.factor +++ b/extra/time/time.factor @@ -6,14 +6,23 @@ math.functions math.parser peg.ebnf sequences strings vectors ; IN: time -: timestring ( timestamp -- string ) +: >timestring ( timestamp -- string ) [ hour>> ] keep [ minute>> ] keep second>> 3array [ number>string 2 CHAR: 0 pad-left ] map ":" join ; inline -: datestring ( timestamp -- string ) +: >datestring ( timestamp -- string ) [ month>> ] keep [ day>> ] keep year>> 3array [ number>string 2 CHAR: 0 pad-left ] map "/" join ; inline +: week-of-year-sunday ( timestamp -- n ) + dup clone 1 >>month 1 >>day day-of-week dup 0 > [ 7 swap - ] when + [ day-of-year ] dip 2dup < [ 0 2nip ] [ - 7 / 1+ >fixnum ] if ; + +: week-of-year-monday ( timestamp -- n ) + dup clone 1 >>month 1 >>day day-of-week dup 1 > [ 7 swap - ] when + [ day-of-year ] dip 2dup < [ 0 2nip ] [ - 7 / 1+ >fixnum ] if ; + + [[ [ dup second>> round number>string 2 CHAR fmt-U = "U" => [[ [ "Not yet implemented" throw ] ]] fmt-w = "w" => [[ [ dup day-of-week number>string ] ]] fmt-W = "W" => [[ [ "Not yet implemented" throw ] ]] -fmt-x = "x" => [[ [ dup datestring ] ]] -fmt-X = "X" => [[ [ dup timestring ] ]] +fmt-x = "x" => [[ [ dup >datestring ] ]] +fmt-X = "X" => [[ [ dup >timestring ] ]] fmt-y = "y" => [[ [ dup year>> 100 mod number>string ] ]] fmt-Y = "Y" => [[ [ dup year>> number>string ] ]] fmt-Z = "Z" => [[ [ "Not yet implemented" throw ] ]] From e9a36ebda33d2d55659f7e7d328821a337e9b788 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Mon, 13 Oct 2008 06:19:21 -0700 Subject: [PATCH 027/150] strftime: Some fixes to support week-of-year. --- extra/time/time-docs.factor | 4 ++-- extra/time/time.factor | 14 +++++++------- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/extra/time/time-docs.factor b/extra/time/time-docs.factor index b0ca12e9c6..8fbc59e315 100644 --- a/extra/time/time-docs.factor +++ b/extra/time/time-docs.factor @@ -27,9 +27,9 @@ ARTICLE: "strftime" "Formatted timestamps" { "%M" "Minute as a decimal number [00,59]." } { "%p" "Either AM or PM." } { "%S" "Second as a decimal number [00,59]." } - { "%U" "Week number of the year (Sunday as the first day of the week) as a decimal numberb [00,53]." } + { "%U" "Week number of the year (Sunday as the first day of the week) as a decimal number [00,53]." } { "%w" "Weekday as a decimal number [0(Sunday),6]." } - { "%W" "Week number of the year (Monday as the first day of the week) as a decimal numberb [00,53]." } + { "%W" "Week number of the year (Monday as the first day of the week) as a decimal number [00,53]." } { "%x" "Date representation." } { "%X" "Time representation." } { "%y" "Year without century as a decimal number [00,99]." } diff --git a/extra/time/time.factor b/extra/time/time.factor index d0411bd5bf..be19fb0919 100644 --- a/extra/time/time.factor +++ b/extra/time/time.factor @@ -14,13 +14,13 @@ IN: time [ month>> ] keep [ day>> ] keep year>> 3array [ number>string 2 CHAR: 0 pad-left ] map "/" join ; inline -: week-of-year-sunday ( timestamp -- n ) - dup clone 1 >>month 1 >>day day-of-week dup 0 > [ 7 swap - ] when +: (week-of-year) ( timestamp day -- n ) + [ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when [ day-of-year ] dip 2dup < [ 0 2nip ] [ - 7 / 1+ >fixnum ] if ; -: week-of-year-monday ( timestamp -- n ) - dup clone 1 >>month 1 >>day day-of-week dup 1 > [ 7 swap - ] when - [ day-of-year ] dip 2dup < [ 0 2nip ] [ - 7 / 1+ >fixnum ] if ; +: week-of-year-sunday ( timestamp -- n ) 0 (week-of-year) ; inline + +: week-of-year-monday ( timestamp -- n ) 1 (week-of-year) ; inline [[ [ dup month>> number>string 2 CHAR: 0 pad fmt-M = "M" => [[ [ dup minute>> number>string 2 CHAR: 0 pad-left ] ]] fmt-p = "p" => [[ [ dup hour>> 12 < [ "AM" ] [ "PM" ] ? ] ]] fmt-S = "S" => [[ [ dup second>> round number>string 2 CHAR: 0 pad-left ] ]] -fmt-U = "U" => [[ [ "Not yet implemented" throw ] ]] +fmt-U = "U" => [[ [ dup week-of-year-sunday ] ]] fmt-w = "w" => [[ [ dup day-of-week number>string ] ]] -fmt-W = "W" => [[ [ "Not yet implemented" throw ] ]] +fmt-W = "W" => [[ [ dup week-of-year-monday ] ]] fmt-x = "x" => [[ [ dup >datestring ] ]] fmt-X = "X" => [[ [ dup >timestring ] ]] fmt-y = "y" => [[ [ dup year>> 100 mod number>string ] ]] From 2676807f72b134eb55a08b865cc542290c45b273 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Wed, 3 Dec 2008 23:53:08 -0600 Subject: [PATCH 028/150] Fix typo --- basis/io/windows/nt/files/files.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) mode change 100644 => 100755 basis/io/windows/nt/files/files.factor diff --git a/basis/io/windows/nt/files/files.factor b/basis/io/windows/nt/files/files.factor old mode 100644 new mode 100755 index e54f032873..892a5c4d31 --- a/basis/io/windows/nt/files/files.factor +++ b/basis/io/windows/nt/files/files.factor @@ -1,6 +1,6 @@ USING: continuations destructors io.buffers io.files io.backend io.timeouts io.ports io.files.private io.windows -io.windows.files io.windows.nt.backend io.encodings.ut16n +io.windows.files io.windows.nt.backend io.encodings.utf16n windows windows.kernel32 kernel libc math threads system environment alien.c-types alien.arrays alien.strings sequences combinators combinators.short-circuit ascii splitting alien From 8db24bdd34b6de9c5b20389e50f7a4491e565991 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 5 Dec 2008 08:25:26 -0600 Subject: [PATCH 029/150] assert-depth now has a static stack effect. This fixes a UI unit test failure --- basis/cocoa/messages/messages.factor | 2 +- basis/help/lint/lint.factor | 23 ++++++++++---------- basis/tools/test/test-docs.factor | 2 +- basis/tools/test/test-tests.factor | 4 ++++ basis/tools/test/test.factor | 2 +- core/combinators/combinators-docs.factor | 12 ---------- core/combinators/combinators.factor | 16 -------------- core/continuations/continuations-docs.factor | 5 +++++ core/continuations/continuations.factor | 3 +++ core/kernel/kernel-docs.factor | 6 +++++ core/parser/parser-tests.factor | 4 +++- core/parser/parser.factor | 2 +- 12 files changed, 37 insertions(+), 44 deletions(-) create mode 100644 basis/tools/test/test-tests.factor diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 4be90a5a95..1c5342b389 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -91,7 +91,7 @@ class-init-hooks global [ H{ } clone or ] change-at : (objc-class) ( name word -- class ) 2dup execute dup [ 2nip ] [ - drop over class-init-hooks get at [ call ] when* + drop over class-init-hooks get at [ assert-depth ] when* 2dup execute dup [ 2nip ] [ 2drop "No such class: " prepend throw ] if diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index c7d505d86a..0a392733ac 100644 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -67,7 +67,7 @@ IN: help.lint vocab-exists? [ "$vocab-link to non-existent vocabulary" throw ] unless ] each ; -: check-rendering ( word element -- ) +: check-rendering ( element -- ) [ print-topic ] with-string-writer drop ; : all-word-help ( words -- seq ) @@ -87,13 +87,14 @@ M: help-error error. : check-word ( word -- ) dup word-help [ [ - dup word-help [ - 2dup check-examples - 2dup check-values - 2dup check-see-also - 2dup nip check-modules - 2dup drop check-rendering - ] assert-depth 2drop + dup word-help '[ + _ _ { + [ check-examples ] + [ check-values ] + [ check-see-also ] + [ [ check-rendering ] [ check-modules ] bi* ] + } 2cleave + ] assert-depth ] check-something ] [ drop ] if ; @@ -101,9 +102,9 @@ M: help-error error. : check-article ( article -- ) [ - dup article-content [ - 2dup check-modules check-rendering - ] assert-depth 2drop + dup article-content + '[ _ check-rendering _ check-modules ] + assert-depth ] check-something ; : files>vocabs ( -- assoc ) diff --git a/basis/tools/test/test-docs.factor b/basis/tools/test/test-docs.factor index f19ffb83a4..3cabff457f 100644 --- a/basis/tools/test/test-docs.factor +++ b/basis/tools/test/test-docs.factor @@ -86,7 +86,7 @@ HELP: test-all { $description "Runs unit tests for all loaded vocabularies." } ; HELP: run-all-tests -{ $values { "prefix" "a vocabulary name" } { "failures" "an association list of unit test failures" } } +{ $values { "failures" "an association list of unit test failures" } } { $description "Runs unit tests for all loaded vocabularies and outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ; HELP: test-failures. diff --git a/basis/tools/test/test-tests.factor b/basis/tools/test/test-tests.factor new file mode 100644 index 0000000000..473335645f --- /dev/null +++ b/basis/tools/test/test-tests.factor @@ -0,0 +1,4 @@ +IN: tools.test.tests +USING: tools.test ; + +\ test-all must-infer diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index 080db86338..704a7f1bd5 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -88,7 +88,7 @@ SYMBOL: this-test : test ( prefix -- ) run-tests test-failures. ; -: run-all-tests ( prefix -- failures ) +: run-all-tests ( -- failures ) "" run-tests ; : test-all ( -- ) diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index 3afc0a3c3d..8d1d9f0d2a 100644 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -29,17 +29,9 @@ $nl $nl "A combinator which can help with implementing methods on " { $link hashcode* } ":" { $subsection recursive-hashcode } -{ $subsection "assertions" } { $subsection "combinators-quot" } { $see-also "quotations" "dataflow" } ; -ARTICLE: "assertions" "Assertions" -"Some words to make assertions easier to enforce:" -{ $subsection assert } -{ $subsection assert= } -"Runtime stack depth checking:" -{ $subsection assert-depth } ; - ABOUT: "combinators" HELP: cleave @@ -167,7 +159,3 @@ HELP: dispatch ( n array -- ) { $values { "n" "a fixnum" } { "array" "an array of quotations" } } { $description "Calls the " { $snippet "n" } "th quotation in the array." } { $warning "This word is in the " { $vocab-link "kernel.private" } " vocabulary because it is an implementation detail used by the generic word system to accelerate method dispatch. It does not perform type or bounds checks, and user code should not need to call it directly." } ; - -HELP: assert-depth -{ $values { "quot" "a quotation" } } -{ $description "Runs a quotation. Throws an error if the total number of elements on the stack is not the same before and after the quotation runs." } ; diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 68eef23691..6edec815da 100644 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -134,22 +134,6 @@ ERROR: no-case ; [ drop linear-case-quot ] } cond ; -! assert-depth -: trim-datastacks ( seq1 seq2 -- seq1' seq2' ) - 2dup [ length ] bi@ min tuck [ tail ] 2bi@ ; - -ERROR: relative-underflow stack ; - -ERROR: relative-overflow stack ; - -: assert-depth ( quot -- ) - [ datastack ] dip dip [ datastack ] dip - 2dup [ length ] compare { - { +lt+ [ trim-datastacks nip relative-underflow ] } - { +eq+ [ 2drop ] } - { +gt+ [ trim-datastacks drop relative-overflow ] } - } case ; inline - ! recursive-hashcode : recursive-hashcode ( n obj quot -- code ) pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index f57be71ca8..3632482162 100644 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -83,6 +83,7 @@ $nl { $subsection with-return } "Reflecting the datastack:" { $subsection with-datastack } +{ $subsection assert-depth } "Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "." { $subsection "continuations.private" } ; @@ -216,6 +217,10 @@ HELP: with-datastack { $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" } } ; +HELP: assert-depth +{ $values { "quot" "a quotation" } } +{ $description "Runs a quotation. Throws an error if the quotation attempts to take input values from the stack, or leave outputs on the stack." } ; + HELP: { $description "Constructs a new continuation." } { $notes "User code should call " { $link continuation } " instead." } ; diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 0f55009608..c7056856b6 100644 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -114,6 +114,9 @@ SYMBOL: return-continuation ] 3 (throw) ] callcc1 2nip ; +: assert-depth ( quot -- ) + { } swap with-datastack { } assert= ; inline + GENERIC: compute-restarts ( error -- seq ) > { 1 2 3 } sequence= ] +[ got>> { 1 2 3 } sequence= ] must-fail-with 2 [ diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 49ab0eb7d4..3f3af935b6 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -307,7 +307,7 @@ print-use-hook global [ [ ] or ] change-at ] recover ; : run-file ( file -- ) - [ dup parse-file call ] assert-depth drop ; + [ parse-file call ] curry assert-depth ; : ?run-file ( path -- ) dup exists? [ run-file ] [ drop ] if ; From 5e0653ce6b8d9955e50a1a05dc31d0bd2f7fb2ac Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 5 Dec 2008 09:03:55 -0600 Subject: [PATCH 030/150] Fix USING: --- basis/cocoa/messages/messages.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 1c5342b389..e33217a691 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types alien.strings arrays assocs -combinators compiler compiler.alien kernel math namespaces make -parser prettyprint prettyprint.sections quotations sequences -strings words cocoa.runtime io macros memoize debugger -io.encodings.ascii effects libc libc.private parser lexer init -core-foundation fry generalizations +continuations combinators compiler compiler.alien kernel math +namespaces make parser prettyprint prettyprint.sections +quotations sequences strings words cocoa.runtime io macros +memoize debugger io.encodings.ascii effects libc libc.private +parser lexer init core-foundation fry generalizations specialized-arrays.direct.alien ; IN: cocoa.messages From 0f8735554b6b7ba906c69c7b56b4cf95fd8e7bf9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 5 Dec 2008 09:04:02 -0600 Subject: [PATCH 031/150] These errors don't exist anymore --- basis/debugger/debugger.factor | 6 ------ 1 file changed, 6 deletions(-) diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 94ceff8a23..35b09713d3 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -72,12 +72,6 @@ M: string error. print ; : try ( quot -- ) [ print-error-and-restarts ] recover ; -M: relative-underflow summary - drop "Too many items removed from data stack" ; - -M: relative-overflow summary - drop "Superfluous items pushed to data stack" ; - : expired-error. ( obj -- ) "Object did not survive image save/load: " write third . ; From aa838dbc2da589457c3854fd890934d62d788e7f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 5 Dec 2008 09:04:16 -0600 Subject: [PATCH 032/150] Fix compile errors --- basis/compiler/codegen/fixup/fixup.factor | 2 +- .../tree/propagation/known-words/known-words.factor | 7 +++---- basis/stack-checker/backend/backend.factor | 2 +- basis/threads/threads.factor | 6 +++--- core/io/streams/c/c.factor | 6 +++--- 5 files changed, 11 insertions(+), 12 deletions(-) diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor index 0302218652..a56ae04a7b 100755 --- a/basis/compiler/codegen/fixup/fixup.factor +++ b/basis/compiler/codegen/fixup/fixup.factor @@ -9,7 +9,7 @@ IN: compiler.codegen.fixup GENERIC: fixup* ( obj -- ) -: code-format 22 getenv ; +: code-format ( -- n ) 22 getenv ; : compiled-offset ( -- n ) building get length code-format * ; diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 163b17094a..59e2c0b9db 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -144,10 +144,9 @@ most-negative-fixnum most-positive-fixnum [a,b] comparison-ops [ dup '[ _ define-comparison-constraints ] each-derived-op ] each -generic-comparison-ops [ - dup specific-comparison - '[ _ _ define-comparison-constraints ] each-derived-op -] each +! generic-comparison-ops [ +! dup specific-comparison define-comparison-constraints +! ] each ! Remove redundant comparisons : fold-comparison ( info1 info2 word -- info ) diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 07030085a6..7f8c920b19 100644 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -148,7 +148,7 @@ M: object apply-object push-literal ; { [ dup inline? ] [ drop f ] } { [ dup deferred? ] [ drop f ] } { [ dup crossref? not ] [ drop f ] } - [ def>> [ [ word? ] [ primitive? not ] bi and ] contains? ] + [ def>> [ word? ] contains? ] } cond ; : ?missing-effect ( word -- ) diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor index 1e04ad88c2..305ef0cca3 100644 --- a/basis/threads/threads.factor +++ b/basis/threads/threads.factor @@ -36,7 +36,7 @@ sleep-entry ; : tchange ( key quot -- ) tnamespace swap change-at ; inline -: threads 64 getenv ; +: threads ( -- assoc ) 64 getenv ; : thread ( id -- thread ) threads at ; @@ -73,9 +73,9 @@ PRIVATE> : ( quot name -- thread ) \ thread new-thread ; -: run-queue 65 getenv ; +: run-queue ( -- dlist ) 65 getenv ; -: sleep-queue 66 getenv ; +: sleep-queue ( -- heap ) 66 getenv ; : resume ( thread -- ) f >>state diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index 47e19d2c40..71c9ffd7d9 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -56,9 +56,9 @@ M: c-reader dispose* M: c-io-backend init-io ; -: stdin-handle 11 getenv ; -: stdout-handle 12 getenv ; -: stderr-handle 61 getenv ; +: stdin-handle ( -- alien ) 11 getenv ; +: stdout-handle ( -- alien ) 12 getenv ; +: stderr-handle ( -- alien ) 61 getenv ; : init-c-stdio ( -- stdin stdout stderr ) stdin-handle From 29aeb707c1b044bdbf46aeccaa1e6781f59c24a3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 5 Dec 2008 11:35:10 -0600 Subject: [PATCH 033/150] fix load error --- basis/html/templates/chloe/compiler/compiler.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/html/templates/chloe/compiler/compiler.factor b/basis/html/templates/chloe/compiler/compiler.factor index ac784f8c2a..d4f34ab8aa 100644 --- a/basis/html/templates/chloe/compiler/compiler.factor +++ b/basis/html/templates/chloe/compiler/compiler.factor @@ -3,7 +3,7 @@ USING: assocs namespaces make kernel sequences accessors combinators strings splitting io io.streams.string present xml.writer xml.data xml.entities html.forms -html.templates html.templates.chloe.syntax ; +html.templates html.templates.chloe.syntax continuations ; IN: html.templates.chloe.compiler : chloe-attrs-only ( assoc -- assoc' ) From f126d0c0e6fcf3ef8833a7fd18efb5f531bbad87 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 5 Dec 2008 11:36:41 -0600 Subject: [PATCH 034/150] fix compile error --- basis/logging/server/server.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/logging/server/server.factor b/basis/logging/server/server.factor index 47656e8655..1872bb0af2 100644 --- a/basis/logging/server/server.factor +++ b/basis/logging/server/server.factor @@ -26,7 +26,7 @@ SYMBOL: log-files : log-stream ( service -- stream ) log-files get [ open-log-stream ] cache ; -: multiline-header 20 CHAR: - ; foldable +: multiline-header ( -- string ) 20 CHAR: - ; foldable : (write-message) ( msg name>> level multi? -- ) [ From 320f3555419b5e94a0a4770c3490de468c7e88c1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 5 Dec 2008 11:39:24 -0600 Subject: [PATCH 035/150] fix load error --- basis/html/templates/chloe/chloe.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/basis/html/templates/chloe/chloe.factor b/basis/html/templates/chloe/chloe.factor index da3f80e9a5..73cc239a56 100644 --- a/basis/html/templates/chloe/chloe.factor +++ b/basis/html/templates/chloe/chloe.factor @@ -4,6 +4,7 @@ USING: accessors kernel sequences combinators kernel fry namespaces make classes.tuple assocs splitting words arrays io io.files io.encodings.utf8 io.streams.string unicode.case mirrors math urls present multiline quotations xml logging +continuations xml.data html.forms html.elements From 3293dde7a2aa19c3498d79ae543dc713f39424d1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 5 Dec 2008 12:53:23 -0600 Subject: [PATCH 036/150] remove unit test --- core/vocabs/loader/loader-tests.factor | 3 --- 1 file changed, 3 deletions(-) diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index 7b53e98df1..e5bd74a981 100644 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -154,9 +154,6 @@ forget-junk [ ] [ [ "vocabs.loader.test.e" forget-vocab ] with-compilation-unit ] unit-test -[ "vocabs.loader.test.e" require ] -[ relative-overflow? ] must-fail-with - 0 "vocabs.loader.test.g" set-global [ From 2e31f7d79230f622bed2650e351baab25fbcc50e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 5 Dec 2008 12:57:36 -0600 Subject: [PATCH 037/150] fix help-lint errors --- basis/threads/threads-docs.factor | 5 +++-- core/io/streams/c/c-docs.factor | 6 +++--- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/basis/threads/threads-docs.factor b/basis/threads/threads-docs.factor index cc2216545d..a1d7e50594 100644 --- a/basis/threads/threads-docs.factor +++ b/basis/threads/threads-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax kernel kernel.private io threads.private continuations init quotations strings -assocs heaps boxes namespaces deques ; +assocs heaps boxes namespaces deques dlists ; IN: threads ARTICLE: "threads-start/stop" "Starting and stopping threads" @@ -82,7 +82,7 @@ $nl { $notes "In most cases, user code should call " { $link spawn } " instead, however for control over the error handler quotation, threads can be created with " { $link } " then passed to " { $link (spawn) } "." } ; HELP: run-queue -{ $values { "queue" deque } } +{ $values { "dlist" dlist } } { $var-description "Global variable holding the queue of runnable threads. Calls to " { $link yield } " switch to the thread which has been in the queue for the longest period of time." $nl "By convention, threads are queued with " { $link push-front } @@ -97,6 +97,7 @@ HELP: resume-with { $description "Adds a thread to the end of the run queue together with an object to pass to the thread. The thread must have previously been suspended by a call to " { $link suspend } "; the object is returned from the " { $link suspend } " call." } ; HELP: sleep-queue +{ $values { "heap" min-heap } } { $var-description "A " { $link min-heap } " storing the queue of sleeping threads." } ; HELP: sleep-time diff --git a/core/io/streams/c/c-docs.factor b/core/io/streams/c/c-docs.factor index 6c640bbdeb..a579153353 100644 --- a/core/io/streams/c/c-docs.factor +++ b/core/io/streams/c/c-docs.factor @@ -61,13 +61,13 @@ HELP: fread ( n alien -- str/f ) { $errors "Throws an error if the input operation failed." } ; HELP: stdin-handle -{ $values { "in" "a C FILE* handle" } } +{ $values { "alien" "a C FILE* handle" } } { $description "Outputs the console standard input file handle." } ; HELP: stdout-handle -{ $values { "out" "a C FILE* handle" } } +{ $values { "alien" "a C FILE* handle" } } { $description "Outputs the console standard output file handle." } ; HELP: stderr-handle -{ $values { "out" "a C FILE* handle" } } +{ $values { "alien" "a C FILE* handle" } } { $description "Outputs the console standard error file handle." } ; From 6860285b07c3611f539a5e1112beccce102a7704 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sat, 6 Dec 2008 04:34:25 +0100 Subject: [PATCH 038/150] FUEL 0.0 : all factor.el functionality in place, plus evaluation. --- extra/fuel/authors.txt | 2 + extra/fuel/fuel-tests.factor | 4 + extra/fuel/fuel.factor | 119 +++++++++++++++ misc/fuel/README | 60 ++++++++ misc/fuel/factor-mode.el | 239 +++++++++++++++++++++++++++++ misc/fuel/fu.el | 26 ++++ misc/fuel/fuel-base.el | 63 ++++++++ misc/fuel/fuel-eval.el | 112 ++++++++++++++ misc/fuel/fuel-font-lock.el | 88 +++++++++++ misc/fuel/fuel-help.el | 208 ++++++++++++++++++++++++++ misc/fuel/fuel-listener.el | 120 +++++++++++++++ misc/fuel/fuel-mode.el | 106 +++++++++++++ misc/fuel/fuel-syntax.el | 281 +++++++++++++++++++++++++++++++++++ 13 files changed, 1428 insertions(+) create mode 100644 extra/fuel/authors.txt create mode 100644 extra/fuel/fuel-tests.factor create mode 100644 extra/fuel/fuel.factor create mode 100644 misc/fuel/README create mode 100644 misc/fuel/factor-mode.el create mode 100644 misc/fuel/fu.el create mode 100644 misc/fuel/fuel-base.el create mode 100644 misc/fuel/fuel-eval.el create mode 100644 misc/fuel/fuel-font-lock.el create mode 100644 misc/fuel/fuel-help.el create mode 100644 misc/fuel/fuel-listener.el create mode 100644 misc/fuel/fuel-mode.el create mode 100644 misc/fuel/fuel-syntax.el diff --git a/extra/fuel/authors.txt b/extra/fuel/authors.txt new file mode 100644 index 0000000000..6acd9d5b04 --- /dev/null +++ b/extra/fuel/authors.txt @@ -0,0 +1,2 @@ +Jose Antonio Ortega Ruiz +Eduardo Cavazos diff --git a/extra/fuel/fuel-tests.factor b/extra/fuel/fuel-tests.factor new file mode 100644 index 0000000000..74bc5d4d45 --- /dev/null +++ b/extra/fuel/fuel-tests.factor @@ -0,0 +1,4 @@ +! Copyright (C) 2008 Your name. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test fuel ; +IN: fuel.tests diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor new file mode 100644 index 0000000000..9203f0fcdd --- /dev/null +++ b/extra/fuel/fuel.factor @@ -0,0 +1,119 @@ +! Copyright (C) 2008 Jose Antonio Ortega Ruiz. +! See http://factorcode.org/license.txt for BSD license. + +USING: accessors arrays classes.tuple compiler.units continuations debugger +eval io io.streams.string kernel listener listener.private +make math namespaces parser prettyprint quotations sequences strings +vectors vocabs.loader ; + +IN: fuel + +! > in set ] + [ use>> clone use set ] + [ ds?>> display-stacks? swap [ on ] [ off ] if ] tri + ] unless ; + +SYMBOL: fuel-eval-result +f clone fuel-eval-result set-global + +SYMBOL: fuel-eval-output +f clone fuel-eval-result set-global + +! PRIVATE> + +GENERIC: fuel-pprint ( obj -- ) + +M: object fuel-pprint pprint ; + +M: f fuel-pprint drop "nil" write ; + +M: integer fuel-pprint pprint ; + +M: string fuel-pprint pprint ; + +M: sequence fuel-pprint + dup empty? [ drop f fuel-pprint ] [ + "(" write + [ " " write ] [ fuel-pprint ] interleave + ")" write + ] if ; + +M: tuple fuel-pprint tuple>array fuel-pprint ; + +M: continuation fuel-pprint drop "~continuation~" write ; + +: fuel-eval-set-result ( obj -- ) + clone fuel-eval-result set-global ; + +: fuel-retort ( -- ) + error get + fuel-eval-result get-global + fuel-eval-output get-global + 3array fuel-pprint ; + +: fuel-forget-error ( -- ) + f error set-global ; + +: (fuel-begin-eval) ( -- ) + push-fuel-status + display-stacks? off + fuel-forget-error + f fuel-eval-result set-global + f fuel-eval-output set-global ; + +: (fuel-end-eval) ( quot -- ) + with-string-writer fuel-eval-output set-global + fuel-retort + pop-fuel-status ; + +: (fuel-eval) ( lines -- ) + [ [ parse-lines ] with-compilation-unit call ] curry [ drop ] recover ; + +: (fuel-eval-each) ( lines -- ) + [ 1vector (fuel-eval) ] each ; + +: (fuel-eval-usings) ( usings -- ) + [ "USING: " prepend " ;" append ] map + (fuel-eval-each) fuel-forget-error ; + +: (fuel-eval-in) ( in -- ) + [ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ; + +: fuel-eval-in-context ( lines in usings -- ) + (fuel-begin-eval) [ + (fuel-eval-usings) + (fuel-eval-in) + (fuel-eval) + ] (fuel-end-eval) ; + +: fuel-begin-eval ( in -- ) + (fuel-begin-eval) + (fuel-eval-in) + fuel-retort ; + +: fuel-eval ( lines -- ) + (fuel-begin-eval) [ (fuel-eval) ] (fuel-end-eval) ; + +: fuel-end-eval ( -- ) + [ ] (fuel-end-eval) ; + + +: fuel-startup ( -- ) + "listener" run ; + +MAIN: fuel-startup diff --git a/misc/fuel/README b/misc/fuel/README new file mode 100644 index 0000000000..b98a23e92a --- /dev/null +++ b/misc/fuel/README @@ -0,0 +1,60 @@ +FUEL, Factor's Ultimate Emacs Library +------------------------------------- + +FUEL provides a complete environment for your Factor coding pleasure +inside Emacs, including source code edition and interaction with a +Factor listener instance running within Emacs. + +FUEL was started by Jose A Ortega as an extension to Ed Cavazos' +original factor.el code. + +Installation +------------ + +FUEL comes bundled with Factor's distribution. The folder misc/fuel +contains Elisp code, and there's a fuel vocabulary in extras/fuel. + +To install FUEL, either add this line to your Emacs initialisation: + + (load-file "/misc/fuel/fu.el") + +or + + (add-to-list load-path "/fuel") + (require 'fuel) + +If all you want is a major mode for editing Factor code with pretty +font colors and indentation, without running the factor listener +inside Emacs, you can use instead: + + (add-to-list load-path "/fuel") + (setq factor-mode-use-fuel nil) + (require 'factor-mode) + +Basic usage +----------- + +If you're using the default factor binary and images locations inside +the Factor's source tree, that should be enough to start using FUEL. +Editing any file with the extension .factor will put you in +factor-mode; try C-hm for a summary of available commands. + +To start the listener, try M-x run-factor. + +Many aspects of the environment can be customized: +M-x customize-group fuel will show you how many. + +Quick key reference +------------------- + + - C-cz : switch to listener + - C-co : cycle between code, tests and docs factor files + + - C-M-x, C-cC-ed : eval definition around point + + - C-cC-da : toggle autodoc mode + - C-cC-dd : help for word at point + - C-cC-ds : short help word at point + +Chords ending in a single letter accept also C- (e.g. C-cC-z is +the same as C-cz). diff --git a/misc/fuel/factor-mode.el b/misc/fuel/factor-mode.el new file mode 100644 index 0000000000..d79930bb22 --- /dev/null +++ b/misc/fuel/factor-mode.el @@ -0,0 +1,239 @@ +;;; factor-mode.el -- mode for editing Factor source + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages, fuel, factor +;; Start date: Tue Dec 02, 2008 21:32 + +;;; Comentary: + +;; Definition of factor-mode, a major Emacs for editing Factor source +;; code. + +;;; Code: + +(require 'fuel-base) +(require 'fuel-syntax) +(require 'fuel-font-lock) + +(require 'ring) + + +;;; Customization: + +(defgroup factor-mode nil + "Major mode for Factor source code" + :group 'fuel) + +(defcustom factor-mode-use-fuel t + "Whether to use the full FUEL facilities in factor mode. + +Set this variable to nil if you just want to use Emacs as the +external editor of your Factor environment, e.g., by putting +these lines in your .emacs: + + (add-to-list 'load-path \"/path/to/factor/misc/fuel\") + (setq factor-mode-use-fuel nil) + (require 'factor-mode) +" + :type 'boolean + :group 'factor-mode) + +(defcustom factor-mode-default-indent-width 4 + "Default indentation width for factor-mode. + +This value will be used for the local variable +`factor-mode-indent-width' in new factor buffers. For existing +code, we first check if `factor-mode-indent-width' is set +explicitly in a local variable section or line (e.g. +'! -*- factor-mode-indent-witdth: 2 -*-'). If that's not the case, +`factor-mode' tries to infer its correct value from the existing +code in the buffer." + :type 'integer + :group 'fuel) + +(defcustom factor-mode-hook nil + "Hook run when entering Factor mode." + :type 'hook + :group 'factor-mode) + + +;;; Syntax table: + +(defun factor-mode--syntax-setup () + (set-syntax-table fuel-syntax--syntax-table) + (set (make-local-variable 'beginning-of-defun-function) + 'fuel-syntax--beginning-of-defun) + (set (make-local-variable 'end-of-defun-function) 'fuel-syntax--end-of-defun) + (set (make-local-variable 'open-paren-in-column-0-is-defun-start) nil) + (fuel-syntax--enable-usings)) + + +;;; Indentation: + +(make-variable-buffer-local + (defvar factor-mode-indent-width factor-mode-default-indent-width + "Indentation width in factor buffers. A local variable.")) + +(defun factor-mode--guess-indent-width () + "Chooses an indentation value from existing code." + (let ((word-cont "^ +[^ ]") + (iw)) + (save-excursion + (beginning-of-buffer) + (while (not iw) + (if (not (re-search-forward fuel-syntax--definition-start-regex nil t)) + (setq iw factor-mode-default-indent-width) + (forward-line) + (when (looking-at word-cont) + (setq iw (current-indentation)))))) + iw)) + +(defun factor-mode--indent-in-brackets () + (save-excursion + (beginning-of-line) + (when (> (fuel-syntax--brackets-depth) 0) + (let ((op (fuel-syntax--brackets-start)) + (cl (fuel-syntax--brackets-end)) + (ln (line-number-at-pos))) + (when (> ln (line-number-at-pos op)) + (if (and (> cl 0) (= ln (line-number-at-pos cl))) + (fuel-syntax--indentation-at op) + (fuel-syntax--increased-indentation (fuel-syntax--indentation-at op)))))))) + +(defun factor-mode--indent-definition () + (save-excursion + (beginning-of-line) + (when (fuel-syntax--at-begin-of-def) 0))) + +(defun factor-mode--indent-setter-line () + (when (fuel-syntax--at-setter-line) + (save-excursion + (let ((indent (and (fuel-syntax--at-constructor-line) (current-indentation)))) + (while (not (or indent + (bobp) + (fuel-syntax--at-begin-of-def) + (fuel-syntax--at-end-of-def))) + (if (fuel-syntax--at-constructor-line) + (setq indent (fuel-syntax--increased-indentation)) + (forward-line -1))) + indent)))) + +(defun factor-mode--indent-continuation () + (save-excursion + (forward-line -1) + (while (and (not (bobp)) + (fuel-syntax--looking-at-emptiness)) + (forward-line -1)) + (cond ((or (fuel-syntax--at-end-of-def) + (fuel-syntax--at-setter-line)) + (fuel-syntax--decreased-indentation)) + ((and (fuel-syntax--at-begin-of-def) + (not (fuel-syntax--at-using))) + (fuel-syntax--increased-indentation)) + (t (current-indentation))))) + +(defun factor-mode--calculate-indentation () + "Calculate Factor indentation for line at point." + (or (and (bobp) 0) + (factor-mode--indent-definition) + (factor-mode--indent-in-brackets) + (factor-mode--indent-setter-line) + (factor-mode--indent-continuation) + 0)) + +(defun factor-mode--indent-line () + "Indent current line as Factor code" + (let ((target (factor-mode--calculate-indentation)) + (pos (- (point-max) (point)))) + (if (= target (current-indentation)) + (if (< (current-column) (current-indentation)) + (back-to-indentation)) + (beginning-of-line) + (delete-horizontal-space) + (indent-to target) + (if (> (- (point-max) pos) (point)) + (goto-char (- (point-max) pos)))))) + +(defun factor-mode--indentation-setup () + (set (make-local-variable 'indent-line-function) 'factor-mode--indent-line) + (setq factor-indent-width (factor-mode--guess-indent-width)) + (setq indent-tabs-mode nil)) + + +;;; Buffer cycling: + +(defconst factor-mode--cycle-endings + '(".factor" "-tests.factor" "-docs.factor")) + +(defconst factor-mode--regex-cycle-endings + (format "\\(.*?\\)\\(%s\\)$" + (regexp-opt factor-mode--cycle-endings))) + +(defconst factor-mode--cycle-endings-ring + (let ((ring (make-ring (length factor-mode--cycle-endings)))) + (dolist (e factor-mode--cycle-endings ring) + (ring-insert ring e)))) + +(defun factor-mode--cycle-next (file) + (let* ((match (string-match factor-mode--regex-cycle-endings file)) + (base (and match (match-string-no-properties 1 file))) + (ending (and match (match-string-no-properties 2 file))) + (idx (and ending (ring-member factor-mode--cycle-endings-ring ending))) + (gfl (lambda (i) (concat base (ring-ref factor-mode--cycle-endings-ring i))))) + (if (not idx) file + (let ((l (length factor-mode--cycle-endings)) (i 1) next) + (while (and (not next) (< i l)) + (when (file-exists-p (funcall gfl (+ idx i))) + (setq next (+ idx i))) + (setq i (1+ i))) + (funcall gfl (or next idx)))))) + +(defun factor-mode-visit-other-file (&optional file) + "Cycle between code, tests and docs factor files." + (interactive) + (find-file (factor-mode--cycle-next (or file (buffer-file-name))))) + + +;;; Keymap: + +(defun factor-mode-insert-and-indent (n) + (interactive "p") + (self-insert-command n) + (indent-for-tab-command)) + +(defvar factor-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [?\]] 'factor-mode-insert-and-indent) + (define-key map [?}] 'factor-mode-insert-and-indent) + (define-key map "\C-m" 'newline-and-indent) + (define-key map "\C-co" 'factor-mode-visit-other-file) + (define-key map "\C-c\C-o" 'factor-mode-visit-other-file) + map)) + +(defun factor-mode--keymap-setup () + (use-local-map factor-mode-map)) + + +;;; Factor mode: + +;;;###autoload +(defun factor-mode () + "A mode for editing programs written in the Factor programming language. +\\{factor-mode-map}" + (interactive) + (kill-all-local-variables) + (setq major-mode 'factor-mode) + (setq mode-name "Factor") + (fuel-font-lock--font-lock-setup) + (factor-mode--keymap-setup) + (factor-mode--indentation-setup) + (factor-mode--syntax-setup) + (when factor-mode-use-fuel (require 'fuel-mode) (fuel-mode)) + (run-hooks 'factor-mode-hook)) + + +(provide 'factor-mode) +;;; factor-mode.el ends here diff --git a/misc/fuel/fu.el b/misc/fuel/fu.el new file mode 100644 index 0000000000..508d7ef3a4 --- /dev/null +++ b/misc/fuel/fu.el @@ -0,0 +1,26 @@ +;;; fu.el --- Startup file for FUEL + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages + +;;; Code: + +(add-to-list 'load-path (file-name-directory load-file-name)) + +(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode)) +(autoload 'factor-mode "factor-mode.el" + "Major mode for editing Factor source." t) + +(autoload 'run-factor "fuel-listener.el" + "Start a Factor listener, or switch to a running one." t) + +(autoload 'fuel-autodoc-mode "fuel-help.el" + "Minor mode showing in the minibuffer a synopsis of Factor word at point." + t) + + + +;;; fu.el ends here diff --git a/misc/fuel/fuel-base.el b/misc/fuel/fuel-base.el new file mode 100644 index 0000000000..a62d16cb32 --- /dev/null +++ b/misc/fuel/fuel-base.el @@ -0,0 +1,63 @@ +;;; fuel-base.el --- Basic FUEL support code + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages + +;;; Commentary: + +;; Basic definitions likely to be used by all FUEL modules. + +;;; Code: + +(defconst fuel-version "1.0") + +;;;###autoload +(defsubst fuel-version () + "Echoes FUEL's version." + (interactive) + (message "FUEL %s" fuel-version)) + + +;;; Customization: + +;;;###autoload +(defgroup fuel nil + "Factor's Ultimate Emacs Library" + :group 'language) + + +;;; Emacs compatibility: + +(eval-after-load "ring" + '(when (not (fboundp 'ring-member)) + (defun ring-member (ring item) + (catch 'found + (dotimes (ind (ring-length ring) nil) + (when (equal item (ring-ref ring ind)) + (throw 'found ind))))))) + + +;;; Utilities + +(defun fuel--shorten-str (str len) + (let ((sl (length str))) + (if (<= sl len) str + (let* ((sep " ... ") + (sepl (length sep)) + (segl (/ (- len sepl) 2))) + (format "%s%s%s" + (substring str 0 segl) + sep + (substring str (- sl segl))))))) + +(defun fuel--shorten-region (begin end len) + (fuel--shorten-str (mapconcat 'identity + (split-string (buffer-substring begin end) nil t) + " ") + len)) + +(provide 'fuel-base) +;;; fuel-base.el ends here diff --git a/misc/fuel/fuel-eval.el b/misc/fuel/fuel-eval.el new file mode 100644 index 0000000000..c92d8a8831 --- /dev/null +++ b/misc/fuel/fuel-eval.el @@ -0,0 +1,112 @@ +;;; fuel-eval.el --- utilities for communication with fuel-listener + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages +;; Start date: Tue Dec 02, 2008 + +;;; Commentary: + +;; Protocols for handling communications via a comint buffer running a +;; factor listener. + +;;; Code: + +(require 'fuel-base) +(require 'fuel-syntax) + + +;;; Syncronous string sending: + +(defvar fuel-eval-log-max-length 16000) + +(defvar fuel-eval--default-proc-function nil) +(defsubst fuel-eval--default-proc () + (and fuel-eval--default-proc-function + (funcall fuel-eval--default-proc-function))) + +(defvar fuel-eval--proc nil) +(defvar fuel-eval--log t) + +(defun fuel-eval--send-string (str) + (let ((proc (or fuel-eval--proc (fuel-eval--default-proc)))) + (when proc + (with-current-buffer (get-buffer-create "*factor messages*") + (goto-char (point-max)) + (when (and (> fuel-eval-log-max-length 0) + (> (point) fuel-eval-log-max-length)) + (erase-buffer)) + (when fuel-eval--log (insert "\n>> " (fuel--shorten-str str 75) "\n")) + (let ((beg (point))) + (comint-redirect-send-command-to-process str (current-buffer) proc nil t) + (with-current-buffer (process-buffer proc) + (while (not comint-redirect-completed) (sleep-for 0 1))) + (goto-char beg) + (current-buffer)))))) + + +;;; Evaluation protocol + +(defsubst fuel-eval--retort-make (err result &optional output) + (list err result output)) + +(defsubst fuel-eval--retort-error (ret) (nth 0 ret)) +(defsubst fuel-eval--retort-result (ret) (nth 1 ret)) +(defsubst fuel-eval--retort-output (ret) (nth 2 ret)) + +(defsubst fuel-eval--retort-p (ret) (listp ret)) + +(defsubst fuel-eval--error-name (err) (car err)) + +(defsubst fuel-eval--make-parse-error-retort (str) + (fuel-eval--retort-make 'parse-retort-error nil str)) + +(defun fuel-eval--parse-retort (buffer) + (save-current-buffer + (set-buffer buffer) + (condition-case nil + (read (current-buffer)) + (error (fuel-eval--make-parse-error-retort + (buffer-substring-no-properties (point) (point-max))))))) + +(defsubst fuel-eval--send/retort (str) + (fuel-eval--parse-retort (fuel-eval--send-string str))) + +(defsubst fuel-eval--eval-begin () + (fuel-eval--send/retort "fuel-begin-eval")) + +(defsubst fuel-eval--eval-end () + (fuel-eval--send/retort "fuel-begin-eval")) + +(defsubst fuel-eval--factor-array (strs) + (format "V{ %S }" (mapconcat 'identity strs " "))) + +(defsubst fuel-eval--eval-strings (strs) + (let ((str (format "%s fuel-eval" (fuel-eval--factor-array strs)))) + (fuel-eval--send/retort str))) + +(defsubst fuel-eval--eval-string (str) + (fuel-eval--eval-strings (list str))) + +(defun fuel-eval--eval-strings/context (strs) + (let ((usings (fuel-syntax--usings-update))) + (fuel-eval--send/retort + (format "%s %S %s fuel-eval-in-context" + (fuel-eval--factor-array strs) + (or fuel-syntax--current-vocab "f") + (if usings (fuel-eval--factor-array usings) "f"))))) + +(defsubst fuel-eval--eval-string/context (str) + (fuel-eval--eval-strings/context (list str))) + +(defun fuel-eval--eval-region/context (begin end) + (let ((lines (split-string (buffer-substring-no-properties begin end) + "[\f\n\r\v]+" t))) + (when (> (length lines) 0) + (fuel-eval--eval-strings/context lines)))) + + +(provide 'fuel-eval) +;;; fuel-eval.el ends here diff --git a/misc/fuel/fuel-font-lock.el b/misc/fuel/fuel-font-lock.el new file mode 100644 index 0000000000..c8673f742b --- /dev/null +++ b/misc/fuel/fuel-font-lock.el @@ -0,0 +1,88 @@ +;;; fuel-font-lock.el -- font lock for factor code + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages, fuel, factor +;; Start date: Wed Dec 03, 2008 21:40 + +;;; Comentary: + +;; Font lock setup for highlighting Factor code. + +;;; Code: + +(require 'fuel-base) +(require 'fuel-syntax) + +(require 'font-lock) + + +;;; Faces: + +(defmacro fuel-font-lock--face (face def doc) + (let ((face (intern (format "factor-font-lock-%s" (symbol-name face)))) + (def (intern (format "font-lock-%s-face" (symbol-name def))))) + `(defface ,face (face-default-spec ,def) + ,(format "Face for %s." doc) + :group 'factor-mode + :group 'faces))) + +(defmacro fuel-font-lock--faces-setup () + (cons 'progn + (mapcar (lambda (f) (cons 'fuel-font-lock--face f)) + '((comment comment "comments") + (constructor type "constructors ()") + (declaration keyword "declaration words") + (parsing-word keyword "parsing words") + (setter-word function-name "setter words (>>foo)") + (stack-effect comment "stack effect specifications") + (string string "strings") + (symbol variable-name "name of symbol being defined") + (type-name type "type names") + (vocabulary-name constant "vocabulary names") + (word function-name "word, generic or method being defined"))))) + +(fuel-font-lock--faces-setup) + + +;;; Font lock: + +(defconst fuel-font-lock--parsing-lock-keywords + (cons '("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word) + (mapcar (lambda (w) `(,(format "\\(^\\| \\)\\(%s\\)\\($\\| \\)" w) + 2 'factor-font-lock-parsing-word)) + fuel-syntax--parsing-words))) + +(defconst fuel-font-lock--font-lock-keywords + `(,@fuel-font-lock--parsing-lock-keywords + (,fuel-syntax--stack-effect-regex . 'factor-font-lock-stack-effect) + (,fuel-syntax--parsing-words-ext-regex . 'factor-font-lock-parsing-word) + (,fuel-syntax--declaration-words-regex 1 'factor-font-lock-declaration) + (,fuel-syntax--word-definition-regex 2 'factor-font-lock-word) + (,fuel-syntax--type-definition-regex 2 'factor-font-lock-type-name) + (,fuel-syntax--method-definition-regex (1 'factor-font-lock-type-name) + (2 'factor-font-lock-word)) + (,fuel-syntax--parent-type-regex 1 'factor-font-lock-type) + (,fuel-syntax--constructor-regex . 'factor-font-lock-constructor) + (,fuel-syntax--setter-regex . 'factor-font-lock-setter-word) + (,fuel-syntax--symbol-definition-regex 2 'factor-font-lock-symbol) + (,fuel-syntax--use-line-regex 1 'factor-font-lock-vocabulary-name)) + "Font lock keywords definition for Factor mode.") + +(defun fuel-font-lock--font-lock-setup (&optional keywords no-syntax) + (set (make-local-variable 'comment-start) "! ") + (set (make-local-variable 'parse-sexp-lookup-properties) t) + (set (make-local-variable 'font-lock-comment-face) 'factor-font-lock-comment) + (set (make-local-variable 'font-lock-string-face) 'factor-font-lock-string) + (set (make-local-variable 'font-lock-defaults) + `(,(or keywords 'fuel-font-lock--font-lock-keywords) + nil nil nil nil + ,@(if no-syntax nil + (list (cons 'font-lock-syntactic-keywords + fuel-syntax--syntactic-keywords)))))) + + +(provide 'fuel-font-lock) +;;; fuel-font-lock.el ends here diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el new file mode 100644 index 0000000000..dcf17d2716 --- /dev/null +++ b/misc/fuel/fuel-help.el @@ -0,0 +1,208 @@ +;;; fuel-help.el -- accessing Factor's help system + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages, fuel, factor +;; Start date: Wed Dec 03, 2008 21:41 + +;;; Comentary: + +;; Modes and functions interfacing Factor's 'see' and 'help' +;; utilities, as well as an ElDoc-based autodoc mode. + +;;; Code: + +(require 'fuel-base) +(require 'fuel-font-lock) +(require 'fuel-eval) + + +;;; Customization: + +(defgroup fuel-help nil + "Options controlling FUEL's help system" + :group 'fuel) + +(defcustom fuel-help-minibuffer-font-lock t + "Whether to use font lock for info messages in the minibuffer." + :group 'fuel-help + :type 'boolean) + +(defcustom fuel-help-always-ask t + "When enabled, always ask for confirmation in help prompts." + :type 'boolean + :group 'fuel-help) + +(defcustom fuel-help-use-minibuffer t + "When enabled, use the minibuffer for short help messages." + :type 'boolean + :group 'fuel-help) + +(defcustom fuel-help-mode-hook nil + "Hook run by `factor-help-mode'." + :type 'hook + :group 'fuel-help) + +(defface fuel-help-font-lock-headlines '((t (:bold t :weight bold))) + "Face for headlines in help buffers." + :group 'fuel-help + :group 'faces) + + +;;; Autodoc mode: + +(defvar fuel-help--font-lock-buffer + (let ((buffer (get-buffer-create " *fuel help minibuffer messages*"))) + (set-buffer buffer) + (fuel-font-lock--font-lock-setup) + buffer)) + +(defun fuel-help--font-lock-str (str) + (set-buffer fuel-help--font-lock-buffer) + (erase-buffer) + (insert str) + (let ((font-lock-verbose nil)) (font-lock-fontify-buffer)) + (buffer-string)) + +(defun fuel-help--word-synopsis (&optional word) + (let ((word (or word (fuel-syntax-symbol-at-point))) + (fuel-eval--log nil)) + (when word + (let ((ret (fuel-eval--eval-string/context + (format "\\ %s synopsis fuel-eval-set-result" word)))) + (when (not (fuel-eval--retort-error ret)) + (if fuel-help-minibuffer-font-lock + (fuel-help--font-lock-str (fuel-eval--retort-result ret)) + (fuel-eval--retort-result ret))))))) + +(make-variable-buffer-local + (defvar fuel-autodoc-mode-string " A" + "Modeline indicator for fuel-autodoc-mode")) + +(define-minor-mode fuel-autodoc-mode + "Toggle Fuel's Autodoc mode. +With no argument, this command toggles the mode. +Non-null prefix argument turns on the mode. +Null prefix argument turns off the mode. + +When Autodoc mode is enabled, a synopsis of the word at point is +displayed in the minibuffer." + :init-value nil + :lighter fuel-autodoc-mode-string + :group 'fuel + + (set (make-local-variable 'eldoc-documentation-function) + (when fuel-autodoc-mode 'fuel-help--word-synopsis)) + (set (make-local-variable 'eldoc-minor-mode-string) nil) + (eldoc-mode fuel-autodoc-mode) + (message "Fuel Autodoc %s" (if fuel-autodoc-mode "enabled" "disabled"))) + + +;;;; Factor help mode: + +(defvar fuel-help-mode-map (make-sparse-keymap) + "Keymap for Factor help mode.") + +(define-key fuel-help-mode-map [(return)] 'fuel-help) + +(defconst fuel-help--headlines + (regexp-opt '("Class description" + "Definition" + "Examples" + "Generic word contract" + "Inputs and outputs" + "Methods" + "Notes" + "Parent topics:" + "See also" + "Syntax" + "Vocabulary" + "Warning" + "Word description") + t)) + +(defconst fuel-help--headlines-regexp (format "^%s" fuel-help--headlines)) + +(defconst fuel-help--font-lock-keywords + `(,@fuel-font-lock--font-lock-keywords + (,fuel-help--headlines-regexp . 'fuel-help-font-lock-headlines))) + +(defun fuel-help-mode () + "Major mode for displaying Factor documentation. +\\{fuel-help-mode-map}" + (interactive) + (kill-all-local-variables) + (use-local-map fuel-help-mode-map) + (setq mode-name "Factor Help") + (setq major-mode 'fuel-help-mode) + + (fuel-font-lock--font-lock-setup fuel-help--font-lock-keywords t) + + (set (make-local-variable 'view-no-disable-on-exit) t) + (view-mode) + (setq view-exit-action + (lambda (buffer) + ;; Use `with-current-buffer' to make sure that `bury-buffer' + ;; also removes BUFFER from the selected window. + (with-current-buffer buffer + (bury-buffer)))) + + (setq fuel-autodoc-mode-string "") + (fuel-autodoc-mode) + (run-mode-hooks 'fuel-help-mode-hook)) + +(defun fuel-help--help-buffer () + (with-current-buffer (get-buffer-create "*fuel-help*") + (fuel-help-mode) + (current-buffer))) + +(defvar fuel-help--history nil) + +(defun fuel-help--show-help (&optional see) + (let* ((def (fuel-syntax-symbol-at-point)) + (prompt (format "See%s help on%s: " (if see " short" "") + (if def (format " (%s)" def) ""))) + (ask (or (not (memq major-mode '(factor-mode fuel-help-mode))) + (not def) + fuel-help-always-ask)) + (def (if ask (read-string prompt nil 'fuel-help--history def) def)) + (cmd (format "\\ %s %s" def (if see "see" "help"))) + (fuel-eval--log nil) + (ret (fuel-eval--eval-string/context cmd)) + (out (fuel-eval--retort-output ret))) + (if (or (fuel-eval--retort-error ret) (empty-string-p out)) + (message "No help for '%s'" def) + (let ((hb (fuel-help--help-buffer)) + (inhibit-read-only t) + (font-lock-verbose nil)) + (set-buffer hb) + (erase-buffer) + (insert out) + (set-buffer-modified-p nil) + (pop-to-buffer hb) + (goto-char (point-min)))))) + + +;;; Interface: see/help commands + +(defun fuel-help-short (&optional arg) + "See a help summary of symbol at point. +By default, the information is shown in the minibuffer. When +called with a prefix argument, the information is displayed in a +separate help buffer." + (interactive "P") + (if (if fuel-help-use-minibuffer (not arg) arg) + (fuel-help--word-synopsis) + (fuel-help--show-help t))) + +(defun fuel-help () + "Show extended help about the symbol at point, using a help +buffer." + (interactive) + (fuel-help--show-help)) + + +(provide 'fuel-help) +;;; fuel-help.el ends here diff --git a/misc/fuel/fuel-listener.el b/misc/fuel/fuel-listener.el new file mode 100644 index 0000000000..958c589220 --- /dev/null +++ b/misc/fuel/fuel-listener.el @@ -0,0 +1,120 @@ +;;; fuel-listener.el --- starting the fuel listener + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages + +;;; Commentary: + +;; Utilities to maintain and switch to a factor listener comint +;; buffer, with an accompanying major fuel-listener-mode. + +;;; Code: + +(require 'fuel-eval) +(require 'fuel-base) +(require 'comint) + + +;;; Customization: + +(defgroup fuel-listener nil + "Interacting with a Factor listener inside Emacs" + :group 'fuel) + +(defcustom fuel-listener-factor-binary "~/factor/factor" + "Full path to the factor executable to use when starting a listener." + :type '(file :must-match t) + :group 'fuel-listener) + +(defcustom fuel-listener-factor-image "~/factor/factor.image" + "Full path to the factor image to use when starting a listener." + :type '(file :must-match t) + :group 'fuel-listener) + +(defcustom fuel-listener-use-other-window t + "Use a window other than the current buffer's when switching to +the factor-listener buffer." + :type 'boolean + :group 'fuel-listener) + +(defcustom fuel-listener-window-allow-split t + "Allow window splitting when switching to the fuel listener +buffer." + :type 'boolean + :group 'fuel-listener) + + +;;; Fuel listener buffer/process: + +(defvar fuel-listener-buffer nil + "The buffer in which the Factor listener is running.") + +(defun fuel-listener--start-process () + (let ((factor (expand-file-name fuel-listener-factor-binary)) + (image (expand-file-name fuel-listener-factor-image))) + (unless (file-executable-p factor) + (error "Could not run factor: %s is not executable" factor)) + (unless (file-readable-p image) + (error "Could not run factor: image file %s not readable" image)) + (setq fuel-listener-buffer + (make-comint "fuel listener" factor nil "-run=fuel" (format "-i=%s" image))) + (with-current-buffer fuel-listener-buffer + (fuel-listener-mode)))) + +(defun fuel-listener--process (&optional start) + (or (and (buffer-live-p fuel-listener-buffer) + (get-buffer-process fuel-listener-buffer)) + (if (not start) + (error "No running factor listener (try M-x run-factor)") + (fuel-listener--start-process) + (fuel-listener--process)))) + +(setq fuel-eval--default-proc-function 'fuel-listener--process) + + +;;; Interface: starting fuel listener + +(defalias 'switch-to-factor 'run-factor) +(defalias 'switch-to-fuel-listener 'run-factor) +;;;###autoload +(defun run-factor (&optional arg) + "Show the fuel-listener buffer, starting the process if needed." + (interactive) + (let ((buf (process-buffer (fuel-listener--process t))) + (pop-up-windows fuel-listener-window-allow-split)) + (if fuel-listener-use-other-window + (pop-to-buffer buf) + (switch-to-buffer buf)))) + + +;;; Fuel listener mode: + +(defconst fuel-listener--prompt-regex "( [^)]* ) ") + +(defun fuel-listener--wait-for-prompt (&optional timeout) + (let ((proc (fuel-listener--process))) + (with-current-buffer fuel-listener-buffer + (goto-char comint-last-input-end) + (while (not (or (re-search-forward comint-prompt-regexp nil t) + (not (accept-process-output proc timeout)))) + (goto-char comint-last-input-end)) + (goto-char (point-max))))) + +(defun fuel-listener--startup () + (fuel-listener--wait-for-prompt) + (fuel-eval--send-string "USE: fuel") + (message "FUEL listener up and running!")) + +(define-derived-mode fuel-listener-mode comint-mode "Fuel Listener" + "Major mode for interacting with an inferior Factor listener process. +\\{fuel-listener-mode-map}" + (set (make-local-variable 'comint-prompt-regexp) + fuel-listener--prompt-regex) + (fuel-listener--startup)) + + +(provide 'fuel-listener) +;;; fuel-listener.el ends here diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el new file mode 100644 index 0000000000..5a3206698e --- /dev/null +++ b/misc/fuel/fuel-mode.el @@ -0,0 +1,106 @@ +;;; fuel-mode.el -- Minor mode enabling FUEL niceties + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages, fuel, factor +;; Start date: Sat Dec 06, 2008 00:52 + +;;; Comentary: + +;; Enhancements to vanilla factor-mode (notably, listener interaction) +;; enabled by means of a minor mode. + +;;; Code: + +(require 'factor-mode) +(require 'fuel-base) +(require 'fuel-syntax) +(require 'fuel-font-lock) +(require 'fuel-help) +(require 'fuel-eval) +(require 'fuel-listener) + + +;;; Customization: + +(defgroup fuel-mode nil + "Mode enabling FUEL's ultimate abilities." + :group 'fuel) + +(defcustom fuel-mode-autodoc-p t + "Whether `fuel-autodoc-mode' gets enable by default in fuel buffers." + :group 'fuel-mode + :type 'boolean) + + +;;; User commands + +(defun fuel-eval-definition (&optional arg) + "Sends definition around point to Fuel's listener for evaluation. +With prefix, switchs the the listener's buffer." + (interactive "P") + (save-excursion + (mark-defun) + (let* ((begin (point)) + (end (mark))) + (unless (< begin end) (error "No evaluable definition around point")) + (let* ((msg (match-string 0)) + (ret (fuel-eval--eval-region/context begin end)) + (err (fuel-eval--retort-error ret))) + (when err (error "%s" err)) + (message "%s" (fuel--shorten-region begin end 70))))) + (when arg (pop-to-buffer fuel-listener-buffer))) + + +;;; Minor mode definition: + +(make-variable-buffer-local + (defvar fuel-mode-string " F" + "Modeline indicator for fuel-mode")) + +(defvar fuel-mode-map (make-sparse-keymap) + "Key map for fuel-mode") + +(define-minor-mode fuel-mode + "Toggle Fuel's mode. +With no argument, this command toggles the mode. +Non-null prefix argument turns on the mode. +Null prefix argument turns off the mode. + +When Fuel mode is enabled, a host of nice utilities for +interacting with a factor listener is at your disposal. +\\{fuel-mode-map}" + :init-value nil + :lighter fuel-mode-string + :group 'fuel + :keymap fuel-mode-map + + (setq fuel-autodoc-mode-string "/A") + (when fuel-mode-autodoc-p (fuel-autodoc-mode fuel-mode))) + + +;;; Keys: + +(defun fuel-mode--key-1 (k c) + (define-key fuel-mode-map (vector '(control ?c) k) c) + (define-key fuel-mode-map (vector '(control ?c) `(control ,k)) c)) + +(defun fuel-mode--key (p k c) + (define-key fuel-mode-map (vector '(control ?c) `(control ,p) k) c) + (define-key fuel-mode-map (vector '(control ?c) `(control ,p) `(control ,k)) c)) + +(fuel-mode--key-1 ?z 'run-factor) + +(define-key fuel-mode-map "\C-\M-x" 'fuel-eval-definition) + +(fuel-mode--key ?e ?d 'fuel-eval-definition) + +(fuel-mode--key ?d ?a 'fuel-autodoc-mode) +(fuel-mode--key ?d ?d 'fuel-help) +(fuel-mode--key ?d ?s 'fuel-help-short) + + +(provide 'fuel-mode) +;;; fuel-mode.el ends here diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el new file mode 100644 index 0000000000..a0485f9183 --- /dev/null +++ b/misc/fuel/fuel-syntax.el @@ -0,0 +1,281 @@ +;;; fuel-syntax.el --- auxiliar definitions for factor code navigation. + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages + +;;; Commentary: + +;; Auxiliar constants and functions to parse factor code. + +;;; Code: + +(require 'thingatpt) + + +;;; Thing-at-point support for factor symbols: + +(defun fuel-syntax--beginning-of-symbol () + "Move point to the beginning of the current symbol." + (while (eq (char-before) ?:) (backward-char)) + (skip-syntax-backward "w_")) + +(defun fuel-syntax--end-of-symbol () + "Move point to the end of the current symbol." + (skip-syntax-forward "w_") + (while (looking-at ":") (forward-char))) + +(put 'factor-symbol 'end-op 'fuel-syntax--end-of-symbol) +(put 'factor-symbol 'beginning-op 'fuel-syntax--beginning-of-symbol) + +(defsubst fuel-syntax-symbol-at-point () + (let ((s (substring-no-properties (thing-at-point 'factor-symbol)))) + (and (> (length s) 0) s))) + + +;;; Regexps galore: + +(defconst fuel-syntax--parsing-words + '("{" "}" "^:" "^::" ";" "<<" ">" + "BIN:" "BV{" "B{" "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CS{" "C{" + "DEFER:" "ERROR:" "EXCLUDE:" "FORGET:" + "GENERIC#" "GENERIC:" "HEX:" "HOOK:" "H{" + "IN:" "INSTANCE:" "INTERSECTION:" + "M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "METHOD:" "MIXIN:" + "OCT:" "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:" + "REQUIRE:" "REQUIRES:" "SINGLETON:" "SLOT:" "SYMBOL:" "SYMBOLS:" + "TUPLE:" "T{" "t\\??" "TYPEDEF:" + "UNION:" "USE:" "USING:" "V{" "VARS:" "W{")) + +(defconst fuel-syntax--parsing-words-ext-regex + (regexp-opt '("B" "call-next-method" "delimiter" "f" "initial:" "read-only") + 'words)) + +(defconst fuel-syntax--declaration-words + '("flushable" "foldable" "inline" "parsing" "recursive")) + +(defconst fuel-syntax--declaration-words-regex + (regexp-opt fuel-syntax--declaration-words 'words)) + +(defsubst fuel-syntax--second-word-regex (prefixes) + (format "^%s +\\([^ \r\n]+\\)" (regexp-opt prefixes t))) + +(defconst fuel-syntax--method-definition-regex + "^M: +\\([^ ]+\\) +\\([^ ]+\\)") + +(defconst fuel-syntax--word-definition-regex + (fuel-syntax--second-word-regex '(":" "::" "GENERIC:"))) + +(defconst fuel-syntax--type-definition-regex + (fuel-syntax--second-word-regex '("TUPLE:" "SINGLETON:"))) + +(defconst fuel-syntax--parent-type-regex "^TUPLE: +[^ ]+ +< +\\([^ ]+\\)") + +(defconst fuel-syntax--constructor-regex "<[^ >]+>") + +(defconst fuel-syntax--setter-regex "\\W>>[^ ]+\\b") + +(defconst fuel-syntax--symbol-definition-regex + (fuel-syntax--second-word-regex '("SYMBOL:" "VAR:"))) + +(defconst fuel-syntax--stack-effect-regex " ( .* )") + +(defconst fuel-syntax--using-lines-regex "^USING: +\\([^;]+\\);") + +(defconst fuel-syntax--use-line-regex "^USE: +\\(.*\\)$") + +(defconst fuel-syntax--current-vocab-regex "^IN: +\\([^ \r\n\f]+\\)") + +(defconst fuel-syntax--sub-vocab-regex "^<\\([^ \n]+\\) *$") + +(defconst fuel-syntax--definition-starters-regex + (regexp-opt '("VARS" "TUPLE" "MACRO" "MACRO:" "M" ":" ""))) + +(defconst fuel-syntax--definition-start-regex + (format "^\\(%s:\\) " fuel-syntax--definition-starters-regex)) + +(defconst fuel-syntax--definition-end-regex + (format "\\(\\(^\\| +\\);\\( +%s\\)*\\($\\| +\\)\\)" + fuel-syntax--declaration-words-regex)) + +(defconst fuel-syntax--single-liner-regex + (format "^%s" (regexp-opt '("DEFER:" "GENERIC:" "IN:" + "PRIVATE>" "" table) + + ;; Parenthesis + (modify-syntax-entry ?\[ "(] " table) + (modify-syntax-entry ?\] ")[ " table) + (modify-syntax-entry ?{ "(} " table) + (modify-syntax-entry ?} "){ " table) + + (modify-syntax-entry ?\( "()" table) + (modify-syntax-entry ?\) ")(" table) + + ;; Strings + (modify-syntax-entry ?\" "\"" table) + (modify-syntax-entry ?\\ "/" table) + table) + "Syntax table used while in Factor mode.") + +(defconst fuel-syntax--syntactic-keywords + `(("\\(#!\\)" (1 "<")) + (" \\(!\\)" (1 "<")) + ("^\\(!\\)" (1 "<")) + ("\\(!(\\) .* \\()\\)" (1 "<") (2 ">")) + ("\\([[({]\\)\\([^ \"\n]\\)" (1 "_") (2 "_")) + ("\\([^ \"\n]\\)\\([])}]\\)" (1 "_") (2 "_")))) + + +;;; Source code analysis: + +(defsubst fuel-syntax--brackets-depth () + (nth 0 (syntax-ppss))) + +(defsubst fuel-syntax--brackets-start () + (nth 1 (syntax-ppss))) + +(defun fuel-syntax--brackets-end () + (save-excursion + (goto-char (fuel-syntax--brackets-start)) + (condition-case nil + (progn (forward-sexp) + (1- (point))) + (error -1)))) + +(defsubst fuel-syntax--indentation-at (pos) + (save-excursion (goto-char pos) (current-indentation))) + +(defsubst fuel-syntax--increased-indentation (&optional i) + (+ (or i (current-indentation)) factor-indent-width)) +(defsubst fuel-syntax--decreased-indentation (&optional i) + (- (or i (current-indentation)) factor-indent-width)) + +(defsubst fuel-syntax--at-begin-of-def () + (looking-at fuel-syntax--begin-of-def-regex)) + +(defsubst fuel-syntax--at-end-of-def () + (looking-at fuel-syntax--end-of-def-regex)) + +(defsubst fuel-syntax--looking-at-emptiness () + (looking-at "^[ \t]*$")) + +(defun fuel-syntax--at-setter-line () + (save-excursion + (beginning-of-line) + (if (not (fuel-syntax--looking-at-emptiness)) + (re-search-forward fuel-syntax--setter-regex (line-end-position) t) + (forward-line -1) + (or (fuel-syntax--at-constructor-line) + (fuel-syntax--at-setter-line))))) + +(defun fuel-syntax--at-constructor-line () + (save-excursion + (beginning-of-line) + (re-search-forward fuel-syntax--constructor-regex (line-end-position) t))) + +(defsubst fuel-syntax--at-using () + (looking-at fuel-syntax--using-lines-regex)) + +(defsubst fuel-syntax--beginning-of-defun (&optional times) + (re-search-backward fuel-syntax--begin-of-def-regex nil t times)) + +(defsubst fuel-syntax--end-of-defun () + (re-search-forward fuel-syntax--end-of-def-regex nil t)) + + +;;; USING/IN: + +(make-variable-buffer-local + (defvar fuel-syntax--current-vocab nil)) + +(make-variable-buffer-local + (defvar fuel-syntax--usings nil)) + +(defun fuel-syntax--current-vocab () + (let ((ip + (save-excursion + (when (re-search-backward fuel-syntax--current-vocab-regex nil t) + (setq fuel-syntax--current-vocab (match-string-no-properties 1)) + (point))))) + (when ip + (let ((pp (save-excursion + (when (re-search-backward fuel-syntax--sub-vocab-regex ip t) + (point))))) + (when (and pp (> pp ip)) + (let ((sub (match-string-no-properties 1))) + (unless (save-excursion (search-backward (format "%s>" sub) pp t)) + (setq fuel-syntax--current-vocab + (format "%s.%s" fuel-syntax--current-vocab (downcase sub))))))))) + fuel-syntax--current-vocab) + +(defun fuel-syntax--usings-update () + (save-excursion + (setq fuel-syntax--usings (list (fuel-syntax--current-vocab))) + (while (re-search-backward fuel-syntax--using-lines-regex nil t) + (dolist (u (split-string (match-string-no-properties 1) nil t)) + (push u fuel-syntax--usings))) + fuel-syntax--usings)) + +(defsubst fuel-syntax--usings-update-hook () + (fuel-syntax--usings-update) + nil) + +(defun fuel-syntax--enable-usings () + (add-hook 'before-save-hook 'fuel-syntax--usings-update-hook nil t) + (fuel-syntax--usings-update)) + +(defsubst fuel-syntax--usings () + (or fuel-syntax--usings (fuel-syntax--usings-update))) + + +(provide 'fuel-syntax) +;;; fuel-syntax.el ends here From f48653c47a59fb78bd639807cedc67e08deaa103 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 5 Dec 2008 23:51:34 -0600 Subject: [PATCH 039/150] Fix compile error --- basis/compiler/codegen/codegen.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 96db72c6ea..21db464079 100644 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -451,7 +451,7 @@ M: ##alien-indirect generate-insn TUPLE: callback-context ; -: current-callback 2 getenv ; +: current-callback ( -- id ) 2 getenv ; : wait-to-return ( token -- ) dup current-callback eq? [ From 044e2867d54d3c4006b973e555c618fbaf43bac1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 5 Dec 2008 23:51:58 -0600 Subject: [PATCH 040/150] Teach compiler about string-nth range --- .../tree/propagation/known-words/known-words.factor | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 59e2c0b9db..c98ec24ea8 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -5,7 +5,7 @@ math.partial-dispatch math.intervals math.parser math.order layouts words sequences sequences.private arrays assocs classes classes.algebra combinators generic.math splitting fry locals classes.tuple alien.accessors classes.tuple.private slots.private -definitions +definitions strings.private stack-checker.state compiler.tree.comparisons compiler.tree.propagation.info @@ -242,6 +242,10 @@ generic-comparison-ops [ ] "custom-inlining" set-word-prop ] each +\ string-nth [ + 2drop fixnum 0 23 2^ [a,b] +] "outputs" set-word-prop + { alien-signed-1 alien-unsigned-1 From 82cf6530c61e2b30180d6309cd0dcf185a4e48fa Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 5 Dec 2008 23:52:09 -0600 Subject: [PATCH 041/150] set-string-nth-fast intrinsic was busted --- basis/cpu/x86/x86.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index d7234eb389..8dac1efed6 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -391,7 +391,7 @@ M:: x86 %string-nth ( dst src index temp -- ) ] with-small-register ; M:: x86 %set-string-nth-fast ( ch str index temp -- ) - ch { index str } [| new-ch | + ch { index str temp } [| new-ch | new-ch ch ?MOV temp str index [+] LEA temp string-offset [+] new-ch 1 small-reg MOV From 6ee523f48f512554b806f62ce4c6df41178885b8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 5 Dec 2008 23:52:47 -0600 Subject: [PATCH 042/150] Eliminate conditional branch from -fast variant of TR: map; 5% improvement on reverse-complement --- basis/tr/tr.factor | 23 ++++++++++++++++++----- 1 file changed, 18 insertions(+), 5 deletions(-) diff --git a/basis/tr/tr.factor b/basis/tr/tr.factor index 30d0efb28b..66d8df7d44 100644 --- a/basis/tr/tr.factor +++ b/basis/tr/tr.factor @@ -1,13 +1,25 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: byte-arrays strings sequences sequences.private -fry kernel words parser lexer assocs math.order ; +fry kernel words parser lexer assocs math math.order summary ; IN: tr +ERROR: bad-tr ; + +M: bad-tr summary + drop "TR: can only be used with ASCII characters" ; + : TR: scan parse-definition unclip-last [ unclip-last ] dip compute-tr + [ check-tr ] [ [ create-tr ] dip define-tr ] - [ [ "-fast" append create-tr ] dip define-fast-tr ] 2bi ; + [ [ "-fast" append create-tr ] dip define-fast-tr ] 2tri ; parsing From 3673a3e7c7c8da13012842b7952c54fce2c9fd67 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 5 Dec 2008 23:53:16 -0600 Subject: [PATCH 043/150] Use stack effect literals instead of in PEG, and don't use smart combinators --- basis/peg/peg.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor index 1fb5909bcf..8a62365f53 100644 --- a/basis/peg/peg.factor +++ b/basis/peg/peg.factor @@ -4,8 +4,7 @@ USING: kernel sequences strings fry namespaces make math assocs debugger io vectors arrays math.parser math.order vectors combinators classes sets unicode.categories compiler.units parser words quotations effects memoize accessors -locals effects splitting combinators.short-circuit -combinators.short-circuit.smart generalizations ; +locals effects splitting combinators.short-circuit generalizations ; IN: peg USE: prettyprint @@ -278,7 +277,8 @@ GENERIC: (compile) ( peg -- quot ) : parser-body ( parser -- quot ) #! Return the body of the word that is the compiled version #! of the parser. - gensym 2dup swap peg>> (compile) 0 1 define-declared swap dupd id>> "peg-id" set-word-prop + gensym 2dup swap peg>> (compile) (( -- result )) define-declared + swap dupd id>> "peg-id" set-word-prop [ execute-parser ] curry ; : preset-parser-word ( parser -- parser word ) @@ -306,7 +306,7 @@ SYMBOL: delayed #! Work through all delayed parsers and recompile their #! words to have the correct bodies. delayed get [ - call compile-parser 1quotation 0 1 define-declared + call compile-parser 1quotation (( -- result )) define-declared ] assoc-each ; : compile ( parser -- word ) @@ -421,7 +421,7 @@ M: seq-parser (compile) ( peg -- quot ) [ parsers>> unclip compile-parser 1quotation [ parse-seq-element ] curry , [ compile-parser 1quotation [ merge-errors ] compose [ parse-seq-element ] curry , ] each - ] { } make , \ && , + ] { } make , \ 1&& , ] [ ] make ; TUPLE: choice-parser parsers ; @@ -431,7 +431,7 @@ M: choice-parser (compile) ( peg -- quot ) [ parsers>> [ compile-parser ] map unclip 1quotation , [ 1quotation [ merge-errors ] compose , ] each - ] { } make , \ || , + ] { } make , \ 0|| , ] [ ] make ; TUPLE: repeat0-parser p1 ; From eb43cddb33d0eaaf279599b95cf66836a195dd5c Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sat, 6 Dec 2008 07:01:12 +0100 Subject: [PATCH 044/150] FUEL: fuel-edit-word-at-point, fuel-eval-region, fuel-eval-extended-region. --- extra/fuel/fuel.factor | 2 ++ misc/fuel/README | 6 ++++- misc/fuel/fuel-eval.el | 2 +- misc/fuel/fuel-mode.el | 58 ++++++++++++++++++++++++++++++++++++------ 4 files changed, 58 insertions(+), 10 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 9203f0fcdd..357e7508f4 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -112,6 +112,8 @@ M: continuation fuel-pprint drop "~continuation~" write ; : fuel-end-eval ( -- ) [ ] (fuel-end-eval) ; +: fuel-get-edit-location ( defspec -- ) + where [ first2 [ (normalize-path) ] dip 2array fuel-eval-set-result ] when* ; : fuel-startup ( -- ) "listener" run ; diff --git a/misc/fuel/README b/misc/fuel/README index b98a23e92a..817695f626 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -50,7 +50,11 @@ Quick key reference - C-cz : switch to listener - C-co : cycle between code, tests and docs factor files - - C-M-x, C-cC-ed : eval definition around point + - M-. : edit word at point in Emacs + + - C-C-r, C-cC-er : eval region + - C-M-r, C-cC-ee : eval region, extending it to definition boundaries + - C-M-x, C-cC-ex : eval definition around point - C-cC-da : toggle autodoc mode - C-cC-dd : help for word at point diff --git a/misc/fuel/fuel-eval.el b/misc/fuel/fuel-eval.el index c92d8a8831..bef7171f6f 100644 --- a/misc/fuel/fuel-eval.el +++ b/misc/fuel/fuel-eval.el @@ -38,7 +38,7 @@ (when (and (> fuel-eval-log-max-length 0) (> (point) fuel-eval-log-max-length)) (erase-buffer)) - (when fuel-eval--log (insert "\n>> " (fuel--shorten-str str 75) "\n")) + (when fuel-eval--log (insert "\n>> " (fuel--shorten-str str 256) "\n")) (let ((beg (point))) (comint-redirect-send-command-to-process str (current-buffer) proc nil t) (with-current-buffer (process-buffer proc) diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index 5a3206698e..bd9b127c7d 100644 --- a/misc/fuel/fuel-mode.el +++ b/misc/fuel/fuel-mode.el @@ -37,21 +37,56 @@ ;;; User commands +(defun fuel-eval-region (begin end &optional arg) + "Sends region to Fuel's listener for evaluation. +With prefix, switchs to the listener's buffer afterwards." + (interactive "r\nP") + (let* ((ret (fuel-eval--eval-region/context begin end)) + (err (fuel-eval--retort-error ret))) + (message "%s" (or err (fuel--shorten-region begin end 70)))) + (when arg (pop-to-buffer fuel-listener-buffer))) + +(defun fuel-eval-extended-region (begin end &optional arg) + "Sends region extended outwards to nearest definitions, +to Fuel's listener for evaluation. With prefix, switchs to the +listener's buffer afterwards." + (interactive "r\nP") + (fuel-eval-region (save-excursion (goto-char begin) (mark-defun) (point)) + (save-excursion (goto-char end) (mark-defun) (mark)))) + (defun fuel-eval-definition (&optional arg) "Sends definition around point to Fuel's listener for evaluation. -With prefix, switchs the the listener's buffer." +With prefix, switchs to the listener's buffer afterwards." (interactive "P") (save-excursion (mark-defun) (let* ((begin (point)) (end (mark))) (unless (< begin end) (error "No evaluable definition around point")) - (let* ((msg (match-string 0)) - (ret (fuel-eval--eval-region/context begin end)) - (err (fuel-eval--retort-error ret))) - (when err (error "%s" err)) - (message "%s" (fuel--shorten-region begin end 70))))) - (when arg (pop-to-buffer fuel-listener-buffer))) + (fuel-eval-region begin end)))) + +(defun fuel-edit-word-at-point (&optional arg) + "Opens a new window visiting the definition of the word at point. +With prefix, asks for the word to edit." + (interactive "P") + (let* ((word (fuel-syntax-symbol-at-point)) + (ask (or arg (not word))) + (word (if ask + (read-string nil + (format "Edit word%s: " + (if word (format " (%s)" word) "")) + word) + word))) + (let* ((ret (fuel-eval--eval-string/context + (format "\\ %s fuel-get-edit-location" word))) + (err (fuel-eval--retort-error ret)) + (loc (fuel-eval--retort-result ret))) + (when (or err (not loc) (not (listp loc)) (not (stringp (car loc)))) + (error "Couldn't find edit location for '%s'" word)) + (unless (file-readable-p (car loc)) + (error "Couldn't open '%s' for read" (car loc))) + (find-file-other-window (car loc)) + (goto-line (if (numberp (cadr loc)) (cadr loc) 1))))) ;;; Minor mode definition: @@ -94,8 +129,15 @@ interacting with a factor listener is at your disposal. (fuel-mode--key-1 ?z 'run-factor) (define-key fuel-mode-map "\C-\M-x" 'fuel-eval-definition) +(fuel-mode--key ?e ?x 'fuel-eval-definition) -(fuel-mode--key ?e ?d 'fuel-eval-definition) +(fuel-mode--key-1 ?r 'fuel-eval-region) +(fuel-mode--key ?e ?r 'fuel-eval-region) + +(define-key fuel-mode-map "\C-\M-r" 'fuel-eval-extended-region) +(fuel-mode--key ?e ?e 'fuel-eval-extended-region) + +(define-key fuel-mode-map "\M-." 'fuel-edit-word-at-point) (fuel-mode--key ?d ?a 'fuel-autodoc-mode) (fuel-mode--key ?d ?d 'fuel-help) From b06cfc622525db32117375f467eec9f4026b2067 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Dec 2008 00:12:07 -0600 Subject: [PATCH 045/150] Update ppc backend for recent string intrinsic changes --- basis/cpu/ppc/ppc.factor | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 6b51585750..46986dc5e6 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -139,9 +139,9 @@ M:: ppc %string-nth ( dst src index temp -- ) "end" define-label temp src index ADD dst temp string-offset LBZ + 0 dst HEX: 80 CMPI + "end" get BLT temp src string-aux-offset LWZ - 0 temp \ f tag-number CMPI - "end" get BEQ temp temp index ADD temp temp index ADD temp temp byte-array-offset LHZ @@ -150,6 +150,10 @@ M:: ppc %string-nth ( dst src index temp -- ) "end" resolve-label ] with-scope ; +M:: ppc %set-string-nth-fast ( ch obj index temp -- ) + temp obj index ADD + ch temp string-offset STB ; + M: ppc %add ADD ; M: ppc %add-imm ADDI ; M: ppc %sub swap SUBF ; From c41a0cf6a226300a24c88a4ea9f1ebc81925a5d7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Dec 2008 00:20:49 -0600 Subject: [PATCH 046/150] Add new words to tools.annotations to annotate words with timing code --- .../tools/annotations/annotations-docs.factor | 18 +++++++++++ .../annotations/annotations-tests.factor | 2 +- basis/tools/annotations/annotations.factor | 30 +++++++++++++++---- 3 files changed, 44 insertions(+), 6 deletions(-) diff --git a/basis/tools/annotations/annotations-docs.factor b/basis/tools/annotations/annotations-docs.factor index c61b4547a9..acb6d6dd2a 100644 --- a/basis/tools/annotations/annotations-docs.factor +++ b/basis/tools/annotations/annotations-docs.factor @@ -4,9 +4,17 @@ IN: tools.annotations ARTICLE: "tools.annotations" "Word annotations" "The word annotation feature modifies word definitions to add debugging code. You can restore the old definition by calling " { $link reset } " on the word in question." +$nl +"Printing messages when a word is called or returns:" { $subsection watch } +{ $subsection watch-vars } +"Starting the walker when a word is called:" { $subsection breakpoint } { $subsection breakpoint-if } +"Timing words:" +{ $subsection reset-word-timing } +{ $subsection add-timing } +{ $subsection word-timing. } "All of the above words are implemented using a single combinator which applies a quotation to a word definition to yield a new definition:" { $subsection annotate } ; @@ -63,3 +71,13 @@ HELP: word-inputs { "seq" sequence } } { $description "Makes a sequence of the inputs to a word by counting the number of inputs in the stack effect and saving that many items from the datastack." } ; +HELP: add-timing +{ $values { "word" word } } +{ $description "Adds timing code to a word, which records its total running time, including that of words it calls, on every invocation." } +{ $see-also "tools.time" } ; + +HELP: reset-word-timing +{ $description "Resets the word timing table." } ; + +HELP: word-timing. +{ $description "Prints the word timing table." } ; diff --git a/basis/tools/annotations/annotations-tests.factor b/basis/tools/annotations/annotations-tests.factor index 1e1eccb8b5..1e766e3dec 100644 --- a/basis/tools/annotations/annotations-tests.factor +++ b/basis/tools/annotations/annotations-tests.factor @@ -1,4 +1,4 @@ -USING: tools.test tools.annotations math parser eval +USING: tools.test tools.annotations tools.time math parser eval io.streams.string kernel ; IN: tools.annotations.tests diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor index 9847b16bc2..e5f6af2267 100644 --- a/basis/tools/annotations/annotations.factor +++ b/basis/tools/annotations/annotations.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel words parser io summary quotations -sequences prettyprint continuations effects definitions -compiler.units namespaces assocs tools.walker generic -inspector fry ; +USING: accessors kernel math sorting words parser io summary +quotations sequences prettyprint continuations effects +definitions compiler.units namespaces assocs tools.walker +tools.time generic inspector fry ; IN: tools.annotations GENERIC: reset ( word -- ) @@ -20,9 +20,11 @@ M: word reset f "unannotated-def" set-word-prop ] [ drop ] if ; +ERROR: cannot-annotate-twice word ; + : annotate ( word quot -- ) over "unannotated-def" word-prop [ - "Cannot annotate a word twice" throw + over cannot-annotate-twice ] when [ over dup def>> "unannotated-def" set-word-prop @@ -82,3 +84,21 @@ M: word annotate-methods : breakpoint-if ( word quot -- ) '[ [ _ [ [ break ] when ] ] dip 3append ] annotate-methods ; + +SYMBOL: word-timing + +H{ } clone word-timing set-global + +: reset-word-timing ( -- ) + word-timing get clear-assoc ; + +: (add-timing) ( def word -- def' ) + '[ _ benchmark _ word-timing get at+ ] ; + +: add-timing ( word -- ) + dup '[ _ (add-timing) ] annotate ; + +: word-timing. ( -- ) + word-timing get + >alist [ 1000000 /f ] assoc-map sort-values + simple-table. ; From 731361d07a1bb48347e2aa970b54260eb1f9f871 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sat, 6 Dec 2008 07:34:11 +0100 Subject: [PATCH 047/150] FUEL: Oops, fix previous patch. --- extra/fuel/fuel.factor | 2 +- misc/fuel/README | 2 +- misc/fuel/fuel-listener.el | 4 ++++ 3 files changed, 6 insertions(+), 2 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 357e7508f4..d8a363ca71 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays classes.tuple compiler.units continuations debugger -eval io io.streams.string kernel listener listener.private +definitions eval io io.files io.streams.string kernel listener listener.private make math namespaces parser prettyprint quotations sequences strings vectors vocabs.loader ; diff --git a/misc/fuel/README b/misc/fuel/README index 817695f626..078490abfd 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -52,7 +52,7 @@ Quick key reference - M-. : edit word at point in Emacs - - C-C-r, C-cC-er : eval region + - C-cr, C-cC-er : eval region - C-M-r, C-cC-ee : eval region, extending it to definition boundaries - C-M-x, C-cC-ex : eval definition around point diff --git a/misc/fuel/fuel-listener.el b/misc/fuel/fuel-listener.el index 958c589220..c741a77a5d 100644 --- a/misc/fuel/fuel-listener.el +++ b/misc/fuel/fuel-listener.el @@ -113,8 +113,12 @@ buffer." \\{fuel-listener-mode-map}" (set (make-local-variable 'comint-prompt-regexp) fuel-listener--prompt-regex) + (set (make-local-variable 'comint-prompt-read-only) t) (fuel-listener--startup)) +;; (define-key fuel-listener-mode-map "\C-w" 'comint-kill-region) +;; (define-key fuel-listener-mode-map "\C-k" 'comint-kill-whole-line) + (provide 'fuel-listener) ;;; fuel-listener.el ends here From 735e47fb555a48104bcaa29ef9b9e4140f10cb5d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Dec 2008 01:36:25 -0600 Subject: [PATCH 048/150] Oops, off by 10 --- basis/tools/annotations/annotations.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor index e5f6af2267..ecf3ba0a76 100644 --- a/basis/tools/annotations/annotations.factor +++ b/basis/tools/annotations/annotations.factor @@ -87,7 +87,7 @@ M: word annotate-methods SYMBOL: word-timing -H{ } clone word-timing set-global +word-timing global [ H{ } clone or ] change-at : reset-word-timing ( -- ) word-timing get clear-assoc ; From d7d7f5c9586adf4f8cd392137981d2a5dfaf68fa Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Dec 2008 03:47:10 -0600 Subject: [PATCH 049/150] Fix FUEL authors.txt --- extra/fuel/authors.txt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/fuel/authors.txt b/extra/fuel/authors.txt index 6acd9d5b04..ecfb757fd2 100644 --- a/extra/fuel/authors.txt +++ b/extra/fuel/authors.txt @@ -1,2 +1,2 @@ -Jose Antonio Ortega Ruiz -Eduardo Cavazos +Jose Antonio Ortega Ruiz +Eduardo Cavazos From e95bda8144058c374215fb7ac9ad29305f7d03c1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Dec 2008 03:47:17 -0600 Subject: [PATCH 050/150] Fix help lint warning --- basis/tools/annotations/annotations-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/annotations/annotations-docs.factor b/basis/tools/annotations/annotations-docs.factor index acb6d6dd2a..c88e959b8e 100644 --- a/basis/tools/annotations/annotations-docs.factor +++ b/basis/tools/annotations/annotations-docs.factor @@ -74,7 +74,7 @@ HELP: word-inputs HELP: add-timing { $values { "word" word } } { $description "Adds timing code to a word, which records its total running time, including that of words it calls, on every invocation." } -{ $see-also "tools.time" } ; +{ $see-also "timing" "profiling" } ; HELP: reset-word-timing { $description "Resets the word timing table." } ; From 7771a3e5112d2dfe701e9d616d1180bafc578a08 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Dec 2008 04:57:38 -0600 Subject: [PATCH 051/150] :> word work in progress, split up llocals --- basis/locals/definitions/definitions.factor | 57 ++ basis/locals/errors/errors.factor | 31 ++ basis/locals/fry/fry.factor | 18 + basis/locals/locals.factor | 506 +----------------- basis/locals/macros/macros.factor | 16 + basis/locals/parser/parser.factor | 96 ++++ basis/locals/prettyprint/prettyprint.factor | 47 ++ basis/locals/rewrite/closures/closures.factor | 55 ++ .../rewrite/point-free/point-free.factor | 76 +++ basis/locals/rewrite/sugar/sugar.factor | 122 +++++ basis/locals/types/types.factor | 63 +++ 11 files changed, 590 insertions(+), 497 deletions(-) create mode 100644 basis/locals/definitions/definitions.factor create mode 100644 basis/locals/errors/errors.factor create mode 100644 basis/locals/fry/fry.factor create mode 100644 basis/locals/macros/macros.factor create mode 100644 basis/locals/parser/parser.factor create mode 100644 basis/locals/prettyprint/prettyprint.factor create mode 100644 basis/locals/rewrite/closures/closures.factor create mode 100644 basis/locals/rewrite/point-free/point-free.factor create mode 100644 basis/locals/rewrite/sugar/sugar.factor create mode 100644 basis/locals/types/types.factor diff --git a/basis/locals/definitions/definitions.factor b/basis/locals/definitions/definitions.factor new file mode 100644 index 0000000000..99f9d0bd22 --- /dev/null +++ b/basis/locals/definitions/definitions.factor @@ -0,0 +1,57 @@ +! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors definitions effects generic kernel locals +macros memoize prettyprint prettyprint.backend words ; +IN: locals.definitions + +PREDICATE: lambda-word < word "lambda" word-prop >boolean ; + +M: lambda-word definer drop \ :: \ ; ; + +M: lambda-word definition + "lambda" word-prop body>> ; + +M: lambda-word reset-word + [ call-next-method ] [ f "lambda" set-word-prop ] bi ; + +INTERSECTION: lambda-macro macro lambda-word ; + +M: lambda-macro definer drop \ MACRO:: \ ; ; + +M: lambda-macro definition + "lambda" word-prop body>> ; + +M: lambda-macro reset-word + [ call-next-method ] [ f "lambda" set-word-prop ] bi ; + +INTERSECTION: lambda-method method-body lambda-word ; + +M: lambda-method definer drop \ M:: \ ; ; + +M: lambda-method definition + "lambda" word-prop body>> ; + +M: lambda-method reset-word + [ call-next-method ] [ f "lambda" set-word-prop ] bi ; + +INTERSECTION: lambda-memoized memoized lambda-word ; + +M: lambda-memoized definer drop \ MEMO:: \ ; ; + +M: lambda-memoized definition + "lambda" word-prop body>> ; + +M: lambda-memoized reset-word + [ call-next-method ] [ f "lambda" set-word-prop ] bi ; + +: method-stack-effect ( method -- effect ) + dup "lambda" word-prop vars>> + swap "method-generic" word-prop stack-effect + dup [ out>> ] when + ; + +M: lambda-method synopsis* + dup dup dup definer. + "method-class" word-prop pprint-word + "method-generic" word-prop pprint-word + method-stack-effect effect>string comment. ; diff --git a/basis/locals/errors/errors.factor b/basis/locals/errors/errors.factor new file mode 100644 index 0000000000..9f9c2beecc --- /dev/null +++ b/basis/locals/errors/errors.factor @@ -0,0 +1,31 @@ +! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel summary ; +IN: locals.errors + +ERROR: >r/r>-in-lambda-error ; + +M: >r/r>-in-lambda-error summary + drop + "Explicit retain stack manipulation is not permitted in lambda bodies" ; + +ERROR: binding-form-in-literal-error ; + +M: binding-form-in-literal-error summary + drop "[let, [let* and [wlet not permitted inside literals" ; + +ERROR: local-writer-in-literal-error ; + +M: local-writer-in-literal-error summary + drop "Local writer words not permitted inside literals" ; + +ERROR: local-word-in-literal-error ; + +M: local-word-in-literal-error summary + drop "Local words not permitted inside literals" ; + +ERROR: bad-lambda-rewrite output ; + +M: bad-lambda-rewrite summary + drop "You have found a bug in locals. Please report." ; + diff --git a/basis/locals/fry/fry.factor b/basis/locals/fry/fry.factor new file mode 100644 index 0000000000..9dc924334c --- /dev/null +++ b/basis/locals/fry/fry.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors fry fry.private generalizations kernel +locals.types make sequences ; +IN: locals.fry + +! Support for mixing locals with fry + +M: binding-form count-inputs body>> count-inputs ; + +M: lambda count-inputs body>> count-inputs ; + +M: lambda deep-fry + clone [ shallow-fry swap ] change-body + [ [ vars>> length ] keep '[ _ _ mnswap @ ] , ] [ drop [ncurry] % ] 2bi ; + +M: binding-form deep-fry + clone [ fry '[ @ call ] ] change-body , ; diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index b78b95bc24..494c72bc03 100644 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -1,397 +1,10 @@ ! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces make sequences sequences.private assocs -math vectors strings classes.tuple generalizations parser words -quotations debugger macros arrays macros splitting combinators -prettyprint.backend definitions prettyprint hashtables -prettyprint.sections sets sequences.private effects -effects.parser generic generic.parser compiler.units accessors -locals.backend memoize macros.expander lexer classes summary fry -fry.private ; +USING: lexer locals.parser locals.types macros memoize parser +sequences vocabs.loader words ; IN: locals -ERROR: >r/r>-in-lambda-error ; - -M: >r/r>-in-lambda-error summary - drop - "Explicit retain stack manipulation is not permitted in lambda bodies" ; - -ERROR: binding-form-in-literal-error ; - -M: binding-form-in-literal-error summary - drop "[let, [let* and [wlet not permitted inside literals" ; - -ERROR: local-writer-in-literal-error ; - -M: local-writer-in-literal-error summary - drop "Local writer words not permitted inside literals" ; - -ERROR: local-word-in-literal-error ; - -M: local-word-in-literal-error summary - drop "Local words not permitted inside literals" ; - -ERROR: bad-lambda-rewrite output ; - -M: bad-lambda-rewrite summary - drop "You have found a bug in locals. Please report." ; - - lambda - -TUPLE: binding-form bindings body ; - -TUPLE: let < binding-form ; - -C: let - -TUPLE: let* < binding-form ; - -C: let* - -TUPLE: wlet < binding-form ; - -C: wlet - -M: lambda expand-macros clone [ expand-macros ] change-body ; - -M: lambda expand-macros* expand-macros literal ; - -M: binding-form expand-macros - clone - [ [ expand-macros ] assoc-map ] change-bindings - [ expand-macros ] change-body ; - -M: binding-form expand-macros* expand-macros literal ; - -PREDICATE: local < word "local?" word-prop ; - -: ( name -- word ) - #! Create a local variable identifier - f - dup t "local?" set-word-prop ; - -PREDICATE: local-word < word "local-word?" word-prop ; - -: ( name -- word ) - f dup t "local-word?" set-word-prop ; - -PREDICATE: local-reader < word "local-reader?" word-prop ; - -: ( name -- word ) - f - dup t "local-reader?" set-word-prop ; - -PREDICATE: local-writer < word "local-writer?" word-prop ; - -: ( reader -- word ) - dup name>> "!" append f { - [ nip t "local-writer?" set-word-prop ] - [ swap "local-reader" set-word-prop ] - [ "local-writer" set-word-prop ] - [ nip ] - } 2cleave ; - -TUPLE: quote local ; - -C: quote - -: local-index ( obj args -- n ) - [ dup quote? [ local>> ] when eq? ] with find drop ; - -: read-local-quot ( obj args -- quot ) - local-index neg [ get-local ] curry ; - -GENERIC# localize 1 ( obj args -- quot ) - -M: local localize read-local-quot ; - -M: quote localize [ local>> ] dip read-local-quot ; - -M: local-word localize read-local-quot [ call ] append ; - -M: local-reader localize read-local-quot [ local-value ] append ; - -M: local-writer localize - [ "local-reader" word-prop ] dip - read-local-quot [ set-local-value ] append ; - -M: object localize drop 1quotation ; - -UNION: special local quote local-word local-reader local-writer ; - -: load-locals-quot ( args -- quot ) - [ [ ] ] [ - dup [ local-reader? ] contains? [ - dup [ local-reader? [ 1array ] [ ] ? ] map spread>quot - ] [ [ ] ] if swap length [ load-locals ] curry append - ] if-empty ; - -: drop-locals-quot ( args -- quot ) - [ [ ] ] [ length [ drop-locals ] curry ] if-empty ; - -: point-free-body ( quot args -- newquot ) - [ but-last-slice ] dip '[ _ localize ] map concat ; - -: point-free-end ( quot args -- newquot ) - over peek special? - [ dup drop-locals-quot [ [ peek ] dip localize ] dip append ] - [ drop-locals-quot swap peek suffix ] - if ; - -: (point-free) ( quot args -- newquot ) - [ nip load-locals-quot ] - [ reverse point-free-body ] - [ reverse point-free-end ] - 2tri [ ] 3append-as ; - -: point-free ( quot args -- newquot ) - over empty? [ nip length '[ _ ndrop ] ] [ (point-free) ] if ; - -UNION: lexical local local-reader local-writer local-word ; - -GENERIC: free-vars* ( form -- ) - -: free-vars ( form -- vars ) - [ free-vars* ] { } make prune ; - -M: local-writer free-vars* "local-reader" word-prop , ; - -M: lexical free-vars* , ; - -M: quote free-vars* , ; - -M: object free-vars* drop ; - -M: quotation free-vars* [ free-vars* ] each ; - -M: lambda free-vars* [ vars>> ] [ body>> ] bi free-vars swap diff % ; - -GENERIC: lambda-rewrite* ( obj -- ) - -GENERIC: local-rewrite* ( obj -- ) - -: lambda-rewrite ( form -- form' ) - expand-macros - [ local-rewrite* ] [ ] make - [ [ lambda-rewrite* ] each ] [ ] make ; - -UNION: block callable lambda ; - -GENERIC: block-vars ( block -- seq ) - -GENERIC: block-body ( block -- quot ) - -M: callable block-vars drop { } ; - -M: callable block-body ; - -M: callable local-rewrite* - [ [ local-rewrite* ] each ] [ ] make , ; - -M: lambda block-vars vars>> ; - -M: lambda block-body body>> ; - -M: lambda local-rewrite* - [ vars>> ] [ body>> ] bi - [ [ local-rewrite* ] each ] [ ] make , ; - -M: block lambda-rewrite* - #! Turn free variables into bound variables, curry them - #! onto the body - dup free-vars [ ] map dup % [ - over block-vars prepend - swap block-body [ [ lambda-rewrite* ] each ] [ ] make - swap point-free , - ] keep length \ curry % ; - -GENERIC: rewrite-literal? ( obj -- ? ) - -M: special rewrite-literal? drop t ; - -M: array rewrite-literal? [ rewrite-literal? ] contains? ; - -M: quotation rewrite-literal? [ rewrite-literal? ] contains? ; - -M: wrapper rewrite-literal? drop t ; - -M: hashtable rewrite-literal? drop t ; - -M: vector rewrite-literal? drop t ; - -M: tuple rewrite-literal? drop t ; - -M: object rewrite-literal? drop f ; - -GENERIC: rewrite-element ( obj -- ) - -: rewrite-elements ( seq -- ) - [ rewrite-element ] each ; - -: rewrite-sequence ( seq -- ) - [ rewrite-elements ] [ length , ] [ 0 head , ] tri \ nsequence , ; - -M: array rewrite-element - dup rewrite-literal? [ rewrite-sequence ] [ , ] if ; - -M: vector rewrite-element rewrite-sequence ; - -M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ; - -M: tuple rewrite-element - [ tuple-slots rewrite-elements ] [ class literalize , ] bi \ boa , ; - -M: quotation rewrite-element local-rewrite* ; - -M: lambda rewrite-element local-rewrite* ; - -M: binding-form rewrite-element binding-form-in-literal-error ; - -M: local rewrite-element , ; - -M: local-reader rewrite-element , ; - -M: local-writer rewrite-element - local-writer-in-literal-error ; - -M: local-word rewrite-element - local-word-in-literal-error ; - -M: word rewrite-element literalize , ; - -M: wrapper rewrite-element - dup rewrite-literal? [ wrapped>> rewrite-element ] [ , ] if ; - -M: object rewrite-element , ; - -M: array local-rewrite* rewrite-element ; - -M: vector local-rewrite* rewrite-element ; - -M: tuple local-rewrite* rewrite-element ; - -M: hashtable local-rewrite* rewrite-element ; - -M: wrapper local-rewrite* rewrite-element ; - -M: word local-rewrite* - dup { >r r> load-locals get-local drop-locals } memq? - [ >r/r>-in-lambda-error ] [ call-next-method ] if ; - -M: object lambda-rewrite* , ; - -M: object local-rewrite* , ; - -: make-local ( name -- word ) - "!" ?tail [ - - dup dup name>> set - ] [ ] if - dup dup name>> set ; - -: make-locals ( seq -- words assoc ) - [ [ make-local ] map ] H{ } make-assoc ; - -: make-local-word ( name def -- word ) - [ [ dup name>> set ] [ ] [ ] tri ] dip - "local-word-def" set-word-prop ; - -: push-locals ( assoc -- ) - use get push ; - -: pop-locals ( assoc -- ) - use get delete ; - -SYMBOL: in-lambda? - -: (parse-lambda) ( assoc end -- quot ) - t in-lambda? [ parse-until ] with-variable - >quotation swap pop-locals ; - -: parse-lambda ( -- lambda ) - "|" parse-tokens make-locals dup push-locals - \ ] (parse-lambda) ; - -: parse-binding ( end -- pair/f ) - scan { - { [ dup not ] [ unexpected-eof ] } - { [ 2dup = ] [ 2drop f ] } - [ nip scan-object 2array ] - } cond ; - -: (parse-bindings) ( end -- ) - dup parse-binding dup [ - first2 [ make-local ] dip 2array , - (parse-bindings) - ] [ 2drop ] if ; - -: parse-bindings ( end -- bindings vars ) - [ - [ (parse-bindings) ] H{ } make-assoc - dup push-locals - ] { } make swap ; - -: parse-bindings* ( end -- words assoc ) - [ - [ - namespace push-locals - - (parse-bindings) - ] { } make-assoc - ] { } make swap ; - -: (parse-wbindings) ( end -- ) - dup parse-binding dup [ - first2 [ make-local-word ] keep 2array , - (parse-wbindings) - ] [ 2drop ] if ; - -: parse-wbindings ( end -- bindings vars ) - [ - [ (parse-wbindings) ] H{ } make-assoc - dup push-locals - ] { } make swap ; - -: let-rewrite ( body bindings -- ) - [ - [ 1array ] dip spin '[ @ @ ] - ] assoc-each local-rewrite* \ call , ; - -M: let local-rewrite* - [ body>> ] [ bindings>> ] bi let-rewrite ; - -M: let* local-rewrite* - [ body>> ] [ bindings>> ] bi let-rewrite ; - -M: wlet local-rewrite* - [ body>> ] [ bindings>> ] bi - [ '[ _ ] ] assoc-map - let-rewrite ; - -: parse-locals ( -- vars assoc ) - "(" expect ")" parse-effect - word [ over "declared-effect" set-word-prop ] when* - in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ; - -: parse-locals-definition ( word -- word quot ) - parse-locals \ ; (parse-lambda) - 2dup "lambda" set-word-prop - lambda-rewrite dup length 1 = [ first ] [ bad-lambda-rewrite ] if ; - -: (::) ( -- word def ) CREATE-WORD parse-locals-definition ; - -: (M::) ( -- word def ) - CREATE-METHOD - [ parse-locals-definition ] with-method-definition ; - -: parsed-lambda ( accum form -- accum ) - in-lambda? get [ parsed ] [ lambda-rewrite over push-all ] if ; - -PRIVATE> +: :> scan parsed ; parsing : [| parse-lambda parsed-lambda ; parsing @@ -415,110 +28,9 @@ PRIVATE> : MEMO:: (::) define-memoized ; parsing -> pprint-vars - \ | pprint-word - f > pprint-elements block> - \ ] pprint-word - block> ; - -: pprint-let ( let word -- ) - pprint-word - [ body>> ] [ bindings>> ] bi - \ | pprint-word - t ] assoc-each - block> - \ | pprint-word - - block> - \ ] pprint-word ; - -M: let pprint* \ [let pprint-let ; - -M: wlet pprint* \ [wlet pprint-let ; - -M: let* pprint* \ [let* pprint-let ; - -PREDICATE: lambda-word < word "lambda" word-prop >boolean ; - -M: lambda-word definer drop \ :: \ ; ; - -M: lambda-word definition - "lambda" word-prop body>> ; - -M: lambda-word reset-word - [ call-next-method ] [ f "lambda" set-word-prop ] bi ; - -INTERSECTION: lambda-macro macro lambda-word ; - -M: lambda-macro definer drop \ MACRO:: \ ; ; - -M: lambda-macro definition - "lambda" word-prop body>> ; - -M: lambda-macro reset-word - [ call-next-method ] [ f "lambda" set-word-prop ] bi ; - -INTERSECTION: lambda-method method-body lambda-word ; - -M: lambda-method definer drop \ M:: \ ; ; - -M: lambda-method definition - "lambda" word-prop body>> ; - -M: lambda-method reset-word - [ call-next-method ] [ f "lambda" set-word-prop ] bi ; - -INTERSECTION: lambda-memoized memoized lambda-word ; - -M: lambda-memoized definer drop \ MEMO:: \ ; ; - -M: lambda-memoized definition - "lambda" word-prop body>> ; - -M: lambda-memoized reset-word - [ call-next-method ] [ f "lambda" set-word-prop ] bi ; - -: method-stack-effect ( method -- effect ) - dup "lambda" word-prop vars>> - swap "method-generic" word-prop stack-effect - dup [ out>> ] when - ; - -M: lambda-method synopsis* - dup dup dup definer. - "method-class" word-prop pprint-word - "method-generic" word-prop pprint-word - method-stack-effect effect>string comment. ; - -PRIVATE> - -! Locals and fry -M: binding-form count-inputs body>> count-inputs ; - -M: lambda count-inputs body>> count-inputs ; - -M: lambda deep-fry - clone [ shallow-fry swap ] change-body - [ [ vars>> length ] keep '[ _ _ mnswap @ ] , ] [ drop [ncurry] % ] 2bi ; - -M: binding-form deep-fry - clone [ fry '[ @ call ] ] change-body , ; +{ + "locals.prettyprint" + "locals.definitions" + "locals.macros" + "locals.fry" +} [ require ] each diff --git a/basis/locals/macros/macros.factor b/basis/locals/macros/macros.factor new file mode 100644 index 0000000000..7bde67a792 --- /dev/null +++ b/basis/locals/macros/macros.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs kernel locals.types macros.expander ; +IN: locals.macros + +M: lambda expand-macros clone [ expand-macros ] change-body ; + +M: lambda expand-macros* expand-macros literal ; + +M: binding-form expand-macros + clone + [ [ expand-macros ] assoc-map ] change-bindings + [ expand-macros ] change-body ; + +M: binding-form expand-macros* expand-macros literal ; + diff --git a/basis/locals/parser/parser.factor b/basis/locals/parser/parser.factor new file mode 100644 index 0000000000..5b2e7c3eeb --- /dev/null +++ b/basis/locals/parser/parser.factor @@ -0,0 +1,96 @@ +! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays combinators effects.parser +generic.parser kernel lexer locals.errors +locals.rewrite.closures locals.types make namespaces parser +quotations sequences splitting words ; +IN: locals.parser + +: make-local ( name -- word ) + "!" ?tail [ + + dup dup name>> set + ] [ ] if + dup dup name>> set ; + +: make-locals ( seq -- words assoc ) + [ [ make-local ] map ] H{ } make-assoc ; + +: make-local-word ( name def -- word ) + [ [ dup name>> set ] [ ] [ ] tri ] dip + "local-word-def" set-word-prop ; + +: push-locals ( assoc -- ) + use get push ; + +: pop-locals ( assoc -- ) + use get delete ; + +SYMBOL: in-lambda? + +: (parse-lambda) ( assoc end -- quot ) + t in-lambda? [ parse-until ] with-variable + >quotation swap pop-locals ; + +: parse-lambda ( -- lambda ) + "|" parse-tokens make-locals dup push-locals + \ ] (parse-lambda) ; + +: parse-binding ( end -- pair/f ) + scan { + { [ dup not ] [ unexpected-eof ] } + { [ 2dup = ] [ 2drop f ] } + [ nip scan-object 2array ] + } cond ; + +: (parse-bindings) ( end -- ) + dup parse-binding dup [ + first2 [ make-local ] dip 2array , + (parse-bindings) + ] [ 2drop ] if ; + +: parse-bindings ( end -- bindings vars ) + [ + [ (parse-bindings) ] H{ } make-assoc + dup push-locals + ] { } make swap ; + +: parse-bindings* ( end -- words assoc ) + [ + [ + namespace push-locals + + (parse-bindings) + ] { } make-assoc + ] { } make swap ; + +: (parse-wbindings) ( end -- ) + dup parse-binding dup [ + first2 [ make-local-word ] keep 2array , + (parse-wbindings) + ] [ 2drop ] if ; + +: parse-wbindings ( end -- bindings vars ) + [ + [ (parse-wbindings) ] H{ } make-assoc + dup push-locals + ] { } make swap ; + +: parse-locals ( -- vars assoc ) + "(" expect ")" parse-effect + word [ over "declared-effect" set-word-prop ] when* + in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ; + +: parse-locals-definition ( word -- word quot ) + parse-locals \ ; (parse-lambda) + 2dup "lambda" set-word-prop + rewrite-closures dup length 1 = [ first ] [ bad-lambda-rewrite ] if ; + +: (::) ( -- word def ) CREATE-WORD parse-locals-definition ; + +: (M::) ( -- word def ) + CREATE-METHOD + [ parse-locals-definition ] with-method-definition ; + +: parsed-lambda ( accum form -- accum ) + in-lambda? get [ parsed ] [ rewrite-closures over push-all ] if ; diff --git a/basis/locals/prettyprint/prettyprint.factor b/basis/locals/prettyprint/prettyprint.factor new file mode 100644 index 0000000000..255917a0a5 --- /dev/null +++ b/basis/locals/prettyprint/prettyprint.factor @@ -0,0 +1,47 @@ +! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs kernel locals locals.types +prettyprint.backend prettyprint.sections sequences words ; +IN: locals.prettyprint + +SYMBOL: | + +: pprint-var ( var -- ) + #! Prettyprint a read/write local as its writer, just like + #! in the input syntax: [| x! | ... x 3 + x! ] + dup local-reader? [ + "local-writer" word-prop + ] when pprint-word ; + +: pprint-vars ( vars -- ) [ pprint-var ] each ; + +M: lambda pprint* + > pprint-vars + \ | pprint-word + f > pprint-elements block> + \ ] pprint-word + block> ; + +: pprint-let ( let word -- ) + pprint-word + [ body>> ] [ bindings>> ] bi + \ | pprint-word + t ] assoc-each + block> + \ | pprint-word + + block> + \ ] pprint-word ; + +M: let pprint* \ [let pprint-let ; + +M: wlet pprint* \ [wlet pprint-let ; + +M: let* pprint* \ [let* pprint-let ; + +M: def pprint* + pprint-word local>> pprint-word block> ; diff --git a/basis/locals/rewrite/closures/closures.factor b/basis/locals/rewrite/closures/closures.factor new file mode 100644 index 0000000000..d85155daad --- /dev/null +++ b/basis/locals/rewrite/closures/closures.factor @@ -0,0 +1,55 @@ +! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel locals.rewrite.point-free +locals.rewrite.sugar locals.types macros.expander make +quotations sequences sets words ; +IN: locals.rewrite.closures + +! Step 2: identify free variables and make them into explicit +! parameters of lambdas which are curried on + +GENERIC: rewrite-closures* ( obj -- ) + +: (rewrite-closures) ( form -- form' ) + [ [ rewrite-closures* ] each ] [ ] make ; + +: rewrite-closures ( form -- form' ) + expand-macros (rewrite-sugar) (rewrite-closures) point-free ; + +GENERIC: defs-vars* ( seq form -- seq' ) + +: defs-vars ( form -- vars ) { } [ defs-vars* ] reduce prune ; + +M: def defs-vars* local>> unquote suffix ; + +M: quotation defs-vars* [ defs-vars* ] each ; + +M: object defs-vars* drop ; + +GENERIC: uses-vars* ( seq form -- seq' ) + +: uses-vars ( form -- vars ) { } [ uses-vars* ] reduce prune ; + +M: local-writer uses-vars* "local-reader" word-prop suffix ; + +M: lexical uses-vars* suffix ; + +M: quote uses-vars* local>> uses-vars* ; + +M: object uses-vars* drop ; + +M: quotation uses-vars* [ uses-vars* ] each ; + +: free-vars ( form -- seq ) + [ uses-vars ] [ defs-vars ] bi diff ; + +M: callable rewrite-closures* + #! Turn free variables into bound variables, curry them + #! onto the body + dup free-vars [ ] map + [ % ] + [ var-defs prepend (rewrite-closures) point-free , ] + [ length \ curry % ] + tri ; + +M: object rewrite-closures* , ; diff --git a/basis/locals/rewrite/point-free/point-free.factor b/basis/locals/rewrite/point-free/point-free.factor new file mode 100644 index 0000000000..1741bf044f --- /dev/null +++ b/basis/locals/rewrite/point-free/point-free.factor @@ -0,0 +1,76 @@ +! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays fry kernel locals.backend locals.types +math quotations sequences words combinators make ; +IN: locals.rewrite.point-free + +! Step 3: rewrite locals usage within a single quotation into +! retain stack manipulation + +ERROR: bad-local args obj ; + +: local-index ( args obj -- n ) + 2dup '[ unquote _ eq? ] find drop + dup [ 2nip ] [ drop bad-local ] if ; + +: read-local-quot ( args obj -- quot ) + local-index neg [ get-local ] curry ; + +GENERIC: localize ( args obj -- args quot ) + +M: local localize dupd read-local-quot ; + +M: quote localize dupd local>> read-local-quot ; + +M: local-word localize dupd read-local-quot [ call ] append ; + +M: local-reader localize dupd read-local-quot [ local-value ] append ; + +M: local-writer localize + dupd "local-reader" word-prop + read-local-quot [ set-local-value ] append ; + +M: def localize + local>> [ prefix ] [ local-reader? [ 1array >r ] [ >r ] ? ] bi ; + +M: object localize 1quotation ; + +! We special-case all the :> at the start of a quotation +: load-locals-quot ( args -- quot ) + [ [ ] ] [ + dup [ local-reader? ] contains? [ + dup [ local-reader? [ 1array ] [ ] ? ] map + spread>quot + ] [ [ ] ] if swap length [ load-locals ] curry append + ] if-empty ; + +: load-locals-index ( quot -- n ) + [ [ dup def? [ local>> local-reader? ] [ drop t ] if ] find drop ] + [ length ] bi or ; + +: point-free-start ( quot -- args rest ) + dup load-locals-index + cut [ [ local>> ] map dup load-locals-quot % ] dip ; + +: point-free-body ( args quot -- args ) + [ localize % ] each ; + +: drop-locals-quot ( args -- ) + [ length , [ drop-locals ] % ] unless-empty ; + +: point-free-end ( args obj -- ) + dup special? + [ localize % drop-locals-quot ] + [ [ drop-locals-quot ] [ , ] bi* ] + if ; + +: point-free ( quot -- newquot ) + [ + point-free-start + [ drop-locals-quot ] [ + unclip-last + [ point-free-body ] + [ point-free-end ] + bi* + ] if-empty + ] [ ] make ; diff --git a/basis/locals/rewrite/sugar/sugar.factor b/basis/locals/rewrite/sugar/sugar.factor new file mode 100644 index 0000000000..05b1e2345e --- /dev/null +++ b/basis/locals/rewrite/sugar/sugar.factor @@ -0,0 +1,122 @@ +! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs classes classes.tuple fry +generalizations hashtables kernel locals locals.backend +locals.errors locals.types make quotations sequences vectors +words ; +IN: locals.rewrite.sugar + +! Step 1: rewrite [| [let [let* [wlet into :> forms, turn +! literals with locals in them into code which constructs +! the literal after pushing locals on the stack + +GENERIC: rewrite-sugar* ( obj -- ) + +: (rewrite-sugar) ( form -- form' ) + [ rewrite-sugar* ] [ ] make ; + +GENERIC: quotation-rewrite ( form -- form' ) + +M: callable quotation-rewrite [ [ rewrite-sugar* ] each ] [ ] make ; + +: var-defs ( vars -- defs ) [ ] [ ] map-as ; + +M: lambda quotation-rewrite + [ body>> ] [ vars>> var-defs ] bi + prepend quotation-rewrite ; + +M: callable rewrite-sugar* quotation-rewrite , ; + +M: lambda rewrite-sugar* quotation-rewrite , ; + +GENERIC: rewrite-literal? ( obj -- ? ) + +M: special rewrite-literal? drop t ; + +M: array rewrite-literal? [ rewrite-literal? ] contains? ; + +M: quotation rewrite-literal? [ rewrite-literal? ] contains? ; + +M: wrapper rewrite-literal? drop t ; + +M: hashtable rewrite-literal? drop t ; + +M: vector rewrite-literal? drop t ; + +M: tuple rewrite-literal? drop t ; + +M: object rewrite-literal? drop f ; + +GENERIC: rewrite-element ( obj -- ) + +: rewrite-elements ( seq -- ) + [ rewrite-element ] each ; + +: rewrite-sequence ( seq -- ) + [ rewrite-elements ] [ length , ] [ 0 head , ] tri \ nsequence , ; + +M: array rewrite-element + dup rewrite-literal? [ rewrite-sequence ] [ , ] if ; + +M: vector rewrite-element rewrite-sequence ; + +M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ; + +M: tuple rewrite-element + [ tuple-slots rewrite-elements ] [ class literalize , ] bi \ boa , ; + +M: quotation rewrite-element rewrite-sugar* ; + +M: lambda rewrite-element rewrite-sugar* ; + +M: binding-form rewrite-element binding-form-in-literal-error ; + +M: local rewrite-element , ; + +M: local-reader rewrite-element , ; + +M: local-writer rewrite-element + local-writer-in-literal-error ; + +M: local-word rewrite-element + local-word-in-literal-error ; + +M: word rewrite-element literalize , ; + +M: wrapper rewrite-element + dup rewrite-literal? [ wrapped>> rewrite-element ] [ , ] if ; + +M: object rewrite-element , ; + +M: array rewrite-sugar* rewrite-element ; + +M: vector rewrite-sugar* rewrite-element ; + +M: tuple rewrite-sugar* rewrite-element ; + +M: def rewrite-sugar* , ; + +M: hashtable rewrite-sugar* rewrite-element ; + +M: wrapper rewrite-sugar* rewrite-element ; + +M: word rewrite-sugar* + dup { >r r> load-locals get-local drop-locals } memq? + [ >r/r>-in-lambda-error ] [ call-next-method ] if ; + +M: object rewrite-sugar* , ; + +: let-rewrite ( body bindings -- ) + [ quotation-rewrite % , ] assoc-each + quotation-rewrite % ; + +M: let rewrite-sugar* + [ body>> ] [ bindings>> ] bi let-rewrite ; + +M: let* rewrite-sugar* + [ body>> ] [ bindings>> ] bi let-rewrite ; + +M: wlet rewrite-sugar* + [ body>> ] [ bindings>> ] bi + [ '[ _ ] ] assoc-map + let-rewrite ; diff --git a/basis/locals/types/types.factor b/basis/locals/types/types.factor new file mode 100644 index 0000000000..7a8dac1947 --- /dev/null +++ b/basis/locals/types/types.factor @@ -0,0 +1,63 @@ +! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators kernel sequences words ; +IN: locals.types + +TUPLE: lambda vars body ; + +C: lambda + +TUPLE: binding-form bindings body ; + +TUPLE: let < binding-form ; + +C: let + +TUPLE: let* < binding-form ; + +C: let* + +TUPLE: wlet < binding-form ; + +C: wlet + +TUPLE: quote local ; + +C: quote + +: unquote ( quote -- local ) dup quote? [ local>> ] when ; inline + +TUPLE: def local ; + +C: def + +PREDICATE: local < word "local?" word-prop ; + +: ( name -- word ) + #! Create a local variable identifier + f + dup t "local?" set-word-prop ; + +PREDICATE: local-word < word "local-word?" word-prop ; + +: ( name -- word ) + f dup t "local-word?" set-word-prop ; + +PREDICATE: local-reader < word "local-reader?" word-prop ; + +: ( name -- word ) + f + dup t "local-reader?" set-word-prop ; + +PREDICATE: local-writer < word "local-writer?" word-prop ; + +: ( reader -- word ) + dup name>> "!" append f { + [ nip t "local-writer?" set-word-prop ] + [ swap "local-reader" set-word-prop ] + [ "local-writer" set-word-prop ] + [ nip ] + } 2cleave ; + +UNION: lexical local local-reader local-writer local-word ; +UNION: special lexical quote def ; From a56d480aa69e74465d64fc0b37b381a24e2fa9f3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Dec 2008 09:16:29 -0600 Subject: [PATCH 052/150] Various optimizations leading to a 10% speedup on compiling empty EBNF parser: - open-code getenv primitive - inline tuple predicates in finalization - faster partial dispatch - faster built-in type predicates - faster tuple predicates - faster lo-tag dispatch - compile V{ } clone and H{ } clone more efficiently - add fixnum fast-path to =; avoid indirect branch if two fixnums not eq - faster >alist on hashtables --- .../cfg/alias-analysis/alias-analysis.factor | 7 +- basis/compiler/cfg/hats/hats.factor | 1 + .../cfg/instructions/instructions.factor | 2 + .../cfg/intrinsics/fixnum/fixnum.factor | 3 +- .../compiler/cfg/intrinsics/intrinsics.factor | 3 + .../compiler/cfg/intrinsics/misc/misc.factor | 16 ++++ .../cfg/intrinsics/slots/slots.factor | 3 - basis/compiler/codegen/codegen.factor | 4 + .../tree/finalization/finalization.factor | 27 ++++--- .../tree/propagation/inlining/inlining.factor | 21 +++--- .../known-words/known-words.factor | 16 +++- basis/cpu/architecture/architecture.factor | 2 + basis/cpu/x86/32/32.factor | 2 - basis/cpu/x86/64/64.factor | 3 - basis/cpu/x86/bootstrap.factor | 4 +- basis/cpu/x86/x86.factor | 14 ++-- .../partial-dispatch/partial-dispatch.factor | 74 ++++++++++--------- .../known-words/known-words.factor | 2 +- core/bootstrap/primitives.factor | 7 +- core/classes/builtin/builtin.factor | 32 +++++--- core/classes/tuple/tuple.factor | 15 ++-- core/generic/math/math.factor | 2 +- core/generic/standard/engines/tag/tag.factor | 18 +++-- core/hashtables/hashtables.factor | 2 +- core/kernel/kernel.factor | 5 +- 25 files changed, 180 insertions(+), 105 deletions(-) create mode 100644 basis/compiler/cfg/intrinsics/misc/misc.factor diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index 98569d868c..90227bb5da 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math namespaces assocs hashtables sequences +USING: kernel math namespaces assocs hashtables sequences arrays accessors vectors combinators sets classes compiler.cfg compiler.cfg.registers compiler.cfg.instructions compiler.cfg.copy-prop ; @@ -194,6 +194,7 @@ M: ##slot insn-slot# slot>> constant ; M: ##slot-imm insn-slot# slot>> ; M: ##set-slot insn-slot# slot>> constant ; M: ##set-slot-imm insn-slot# slot>> ; +M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ; M: ##peek insn-object loc>> class ; M: ##replace insn-object loc>> class ; @@ -201,6 +202,7 @@ M: ##slot insn-object obj>> resolve ; M: ##slot-imm insn-object obj>> resolve ; M: ##set-slot insn-object obj>> resolve ; M: ##set-slot-imm insn-object obj>> resolve ; +M: ##alien-global insn-object drop \ ##alien-global ; : init-alias-analysis ( -- ) H{ } clone histories set @@ -224,6 +226,9 @@ M: ##load-immediate analyze-aliases* M: ##load-indirect analyze-aliases* dup dst>> set-heap-ac ; +M: ##alien-global analyze-aliases* + dup dst>> set-heap-ac ; + M: ##allot analyze-aliases* #! A freshly allocated object is distinct from any other #! object. diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index 4b98ccb0ae..ca793de1b7 100644 --- a/basis/compiler/cfg/hats/hats.factor +++ b/basis/compiler/cfg/hats/hats.factor @@ -65,6 +65,7 @@ IN: compiler.cfg.hats : ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline : ^^alien-float ( src -- dst ) ^^d1 ##alien-float ; inline : ^^alien-double ( src -- dst ) ^^d1 ##alien-double ; inline +: ^^alien-global ( symbol library -- dst ) ^^i2 ##alien-global ; inline : ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline : ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline : ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##compare-float ; inline diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 2e7e044739..b34e5f8232 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -161,6 +161,8 @@ INSN: ##set-alien-double < ##alien-setter ; INSN: ##allot < ##flushable size class { temp vreg } ; INSN: ##write-barrier < ##effect card# table ; +INSN: ##alien-global < ##read symbol library ; + ! FFI INSN: ##alien-invoke params ; INSN: ##alien-indirect params ; diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor index 68ee7489f8..69cd5e5669 100644 --- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor +++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor @@ -12,8 +12,7 @@ compiler.cfg.registers ; IN: compiler.cfg.intrinsics.fixnum : emit-both-fixnums? ( -- ) - D 0 ^^peek - D 1 ^^peek + 2inputs ^^or tag-mask get ^^and-imm 0 cc= ^^compare-imm diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index cfc04fa036..41f4bf47a5 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -9,6 +9,7 @@ compiler.cfg.intrinsics.allot compiler.cfg.intrinsics.fixnum compiler.cfg.intrinsics.float compiler.cfg.intrinsics.slots +compiler.cfg.intrinsics.misc compiler.cfg.iterator ; QUALIFIED: kernel QUALIFIED: arrays @@ -23,6 +24,7 @@ IN: compiler.cfg.intrinsics { kernel.private:tag + kernel.private:getenv math.private:both-fixnums? math.private:fixnum+ math.private:fixnum- @@ -94,6 +96,7 @@ IN: compiler.cfg.intrinsics : emit-intrinsic ( node word -- node/f ) { { \ kernel.private:tag [ drop emit-tag iterate-next ] } + { \ kernel.private:getenv [ emit-getenv iterate-next ] } { \ math.private:both-fixnums? [ drop emit-both-fixnums? iterate-next ] } { \ math.private:fixnum+ [ drop [ ##fixnum-add ] [ ##fixnum-add-tail ] emit-fixnum-overflow-op ] } { \ math.private:fixnum- [ drop [ ##fixnum-sub ] [ ##fixnum-sub-tail ] emit-fixnum-overflow-op ] } diff --git a/basis/compiler/cfg/intrinsics/misc/misc.factor b/basis/compiler/cfg/intrinsics/misc/misc.factor new file mode 100644 index 0000000000..f9f2182a4e --- /dev/null +++ b/basis/compiler/cfg/intrinsics/misc/misc.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces layouts sequences kernel +accessors compiler.tree.propagation.info +compiler.cfg.stacks compiler.cfg.hats +compiler.cfg.instructions compiler.cfg.utilities ; +IN: compiler.cfg.intrinsics.misc + +: emit-tag ( -- ) + ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ; + +: emit-getenv ( node -- ) + "userenv" f ^^alien-global + swap node-input-infos first literal>> + [ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot 0 ^^slot ] if* + ds-push ; diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor index 60ae1d2d0a..bc46e6149c 100644 --- a/basis/compiler/cfg/intrinsics/slots/slots.factor +++ b/basis/compiler/cfg/intrinsics/slots/slots.factor @@ -6,9 +6,6 @@ compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions compiler.cfg.utilities ; IN: compiler.cfg.intrinsics.slots -: emit-tag ( -- ) - ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ; - : value-tag ( info -- n ) class>> class-tag ; inline : (emit-slot) ( infos -- dst ) diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 21db464079..fe3da93130 100644 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -236,6 +236,10 @@ M: _gc generate-insn drop %gc ; M: ##loop-entry generate-insn drop %loop-entry ; +M: ##alien-global generate-insn + [ dst>> register ] [ symbol>> ] [ library>> ] tri + %alien-global ; + ! ##alien-invoke GENERIC: reg-size ( register-class -- n ) diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor index 16a27e020a..ecd5429baf 100644 --- a/basis/compiler/tree/finalization/finalization.factor +++ b/basis/compiler/tree/finalization/finalization.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors sequences words memoize classes.builtin +USING: kernel accessors sequences words memoize combinators +classes classes.builtin classes.tuple math.partial-dispatch fry assocs compiler.tree compiler.tree.combinators @@ -12,7 +13,7 @@ IN: compiler.tree.finalization ! See the comment in compiler.tree.late-optimizations. ! This pass runs after propagation, so that it can expand -! built-in type predicates; these cannot be expanded before +! type predicates; these cannot be expanded before ! propagation since we need to see 'fixnum?' instead of ! 'tag 0 eq?' and so on, for semantic reasoning. @@ -33,16 +34,24 @@ M: #shuffle finalize* [ [ in-r>> ] [ out-r>> ] [ mapping>> ] tri '[ _ at ] map sequence= ] bi and [ drop f ] when ; -: builtin-predicate? ( #call -- ? ) - word>> "predicating" word-prop builtin-class? ; - -MEMO: builtin-predicate-expansion ( word -- nodes ) +MEMO: cached-expansion ( word -- nodes ) def>> splice-final ; -: expand-builtin-predicate ( #call -- nodes ) - word>> builtin-predicate-expansion ; +GENERIC: finalize-word ( #call word -- nodes ) + +M: predicate finalize-word + "predicating" word-prop { + { [ dup builtin-class? ] [ drop word>> cached-expansion ] } + { [ dup tuple-class? ] [ drop word>> def>> splice-final ] } + [ drop ] + } cond ; + +! M: math-partial finalize-word +! dup primitive? [ drop ] [ nip cached-expansion ] if ; + +M: word finalize-word drop ; M: #call finalize* - dup builtin-predicate? [ expand-builtin-predicate ] when ; + dup word>> finalize-word ; M: node finalize* ; diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 87a908041e..0e3b8431a6 100644 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -193,13 +193,14 @@ SYMBOL: history #! of bounds value. This case comes up if a parsing word #! calls the compiler at parse time (doing so is #! discouraged, but it should still work.) - { - { [ dup deferred? ] [ 2drop f ] } - { [ dup custom-inlining? ] [ inline-custom ] } - { [ dup \ instance? eq? ] [ inline-instance-check ] } - { [ dup always-inline-word? ] [ inline-word ] } - { [ dup standard-generic? ] [ inline-standard-method ] } - { [ dup math-generic? ] [ inline-math-method ] } - { [ dup method-body? ] [ inline-method-body ] } - [ 2drop f ] - } cond ; + dup custom-inlining? [ 2dup inline-custom ] [ f ] if [ 2drop f ] [ + { + { [ dup deferred? ] [ 2drop f ] } + { [ dup \ instance? eq? ] [ inline-instance-check ] } + { [ dup always-inline-word? ] [ inline-word ] } + { [ dup standard-generic? ] [ inline-standard-method ] } + { [ dup math-generic? ] [ inline-math-method ] } + { [ dup method-body? ] [ inline-method-body ] } + [ 2drop f ] + } cond + ] if ; diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index c98ec24ea8..8242311287 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -5,7 +5,7 @@ math.partial-dispatch math.intervals math.parser math.order layouts words sequences sequences.private arrays assocs classes classes.algebra combinators generic.math splitting fry locals classes.tuple alien.accessors classes.tuple.private slots.private -definitions strings.private +definitions strings.private vectors hashtables stack-checker.state compiler.tree.comparisons compiler.tree.propagation.info @@ -194,6 +194,11 @@ generic-comparison-ops [ 2bi and maybe-or-never ] "outputs" set-word-prop +\ both-fixnums? [ + [ class>> fixnum classes-intersect? not ] either? + f object-info ? +] "outputs" set-word-prop + { { >fixnum fixnum } { bignum>fixnum fixnum } @@ -287,6 +292,15 @@ generic-comparison-ops [ "outputs" set-word-prop ] each +! Generate more efficient code for common idiom +\ clone [ + in-d>> first value-info literal>> { + { V{ } [ [ drop { } 0 vector boa ] ] } + { H{ } [ [ drop hashtable new ] ] } + [ drop f ] + } case +] "custom-inlining" set-word-prop + \ slot [ dup literal?>> [ literal>> swap value-info-slot ] [ 2drop object-info ] if diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index eb93a8dbb5..836385574d 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -120,6 +120,8 @@ HOOK: %set-alien-cell cpu ( ptr value -- ) HOOK: %set-alien-float cpu ( ptr value -- ) HOOK: %set-alien-double cpu ( ptr value -- ) +HOOK: %alien-global cpu ( dst symbol library -- ) + HOOK: %allot cpu ( dst size class temp -- ) HOOK: %write-barrier cpu ( src card# table -- ) HOOK: %gc cpu ( -- ) diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 3df072208d..5e06e72118 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -44,8 +44,6 @@ M: x86.32 param-reg-2 EDX ; M: x86.32 reserved-area-size 0 ; -M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ; - M: x86.32 %alien-invoke (CALL) rel-dlsym ; M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ; diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 6472ec0edf..2077f51e0a 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -158,9 +158,6 @@ M: x86.64 %prepare-box-struct ( -- ) M: x86.64 %prepare-var-args RAX RAX XOR ; -M: x86.64 %alien-global - [ 0 MOV rc-absolute-cell rel-dlsym ] [ dup [] MOV ] bi ; - M: x86.64 %alien-invoke R11 0 MOV rc-absolute-cell rel-dlsym diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 42df1c8437..597a2c9d31 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -381,8 +381,8 @@ big-endian off [ arg0 ds-reg [] MOV - arg0 ds-reg bootstrap-cell neg [+] OR - ds-reg bootstrap-cell ADD + ds-reg bootstrap-cell SUB + arg0 ds-reg [] OR arg0 tag-mask get AND arg0 \ f tag-number MOV arg1 1 tag-fixnum MOV diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 8dac1efed6..c477e98aa7 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -458,19 +458,19 @@ M:: x86 %allot ( dst size class nursery-ptr -- ) dst class store-tagged nursery-ptr size inc-allot-ptr ; -HOOK: %alien-global cpu ( symbol dll register -- ) - M:: x86 %write-barrier ( src card# table -- ) #! Mark the card pointed to by vreg. ! Mark the card card# src MOV card# card-bits SHR - "cards_offset" f table %alien-global + table "cards_offset" f %alien-global + table table [] MOV table card# [+] card-mark MOV ! Mark the card deck card# deck-bits card-bits - SHR - "decks_offset" f table %alien-global + table "decks_offset" f %alien-global + table table [] MOV table card# [+] card-mark MOV ; M: x86 %gc ( -- ) @@ -485,6 +485,9 @@ M: x86 %gc ( -- ) "minor_gc" f %alien-invoke "end" resolve-label ; +M: x86 %alien-global + [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ; + HOOK: stack-reg cpu ( -- reg ) : decr-stack-reg ( n -- ) @@ -595,7 +598,8 @@ M: x86 %prepare-alien-invoke #! Save Factor stack pointers in case the C code calls a #! callback which does a GC, which must reliably trace #! all roots. - "stack_chain" f temp-reg-1 %alien-global + temp-reg-1 "stack_chain" f %alien-global + temp-reg-1 temp-reg-1 [] MOV temp-reg-1 [] stack-reg MOV temp-reg-1 [] cell SUB temp-reg-1 2 cells [+] ds-reg MOV diff --git a/basis/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor index 56da09ccdd..bfa127e7e0 100644 --- a/basis/math/partial-dispatch/partial-dispatch.factor +++ b/basis/math/partial-dispatch/partial-dispatch.factor @@ -3,7 +3,7 @@ USING: accessors kernel kernel.private math math.private words sequences parser namespaces make assocs quotations arrays locals generic generic.math hashtables effects compiler.units -classes.algebra ; +classes.algebra fry combinators ; IN: math.partial-dispatch PREDICATE: math-partial < word @@ -45,60 +45,62 @@ M: word integer-op-input-classes { bitnot fixnum-bitnot } } at swap or ; -:: fixnum-integer-op ( a b fix-word big-word -- c ) - b tag 0 eq? [ - a b fix-word execute - ] [ - a fixnum>bignum b big-word execute - ] if ; inline - -:: integer-fixnum-op ( a b fix-word big-word -- c ) - a tag 0 eq? [ - a b fix-word execute - ] [ - a b fixnum>bignum big-word execute - ] if ; inline - -:: integer-integer-op ( a b fix-word big-word -- c ) - b tag 0 eq? [ - a b fix-word big-word integer-fixnum-op - ] [ - a dup tag 0 eq? [ fixnum>bignum ] when - b big-word execute - ] if ; inline - -: integer-op-combinator ( triple -- word ) +:: integer-fixnum-op-quot ( fix-word big-word -- quot ) [ - [ second name>> % "-" % ] - [ third name>> % "-op" % ] - bi - ] "" make "math.partial-dispatch" lookup ; + [ over fixnum? ] % + fix-word '[ _ execute ] , + big-word '[ fixnum>bignum _ execute ] , + \ if , + ] [ ] make ; + +:: fixnum-integer-op-quot ( fix-word big-word -- quot ) + [ + [ dup fixnum? ] % + fix-word '[ _ execute ] , + big-word '[ [ fixnum>bignum ] dip _ execute ] , + \ if , + ] [ ] make ; + +:: integer-integer-op-quot ( fix-word big-word -- quot ) + [ + [ dup fixnum? ] % + fix-word big-word integer-fixnum-op-quot , + [ + [ over fixnum? [ [ fixnum>bignum ] dip ] when ] % + big-word , + ] [ ] make , + \ if , + ] [ ] make ; : integer-op-word ( triple -- word ) [ name>> ] map "-" join "math.partial-dispatch" create ; -: integer-op-quot ( triple fix-word big-word -- quot ) - rot integer-op-combinator 1quotation 2curry ; +: integer-op-quot ( fix-word big-word triple -- quot ) + [ second ] [ third ] bi 2array { + { { fixnum integer } [ fixnum-integer-op-quot ] } + { { integer fixnum } [ integer-fixnum-op-quot ] } + { { integer integer } [ integer-integer-op-quot ] } + } case ; -: define-integer-op-word ( triple fix-word big-word -- ) +: define-integer-op-word ( fix-word big-word triple -- ) [ - [ 2drop integer-op-word ] [ integer-op-quot ] 3bi + [ 2nip integer-op-word ] [ integer-op-quot ] 3bi (( x y -- z )) define-declared ] [ - 2drop + 2nip [ integer-op-word ] keep "derived-from" set-word-prop ] 3bi ; : define-integer-op-words ( triples fix-word big-word -- ) - [ define-integer-op-word ] 2curry each ; + '[ [ _ _ ] dip define-integer-op-word ] each ; : integer-op-triples ( word -- triples ) { { fixnum integer } { integer fixnum } { integer integer } - } swap [ prefix ] curry map ; + } swap '[ _ prefix ] map ; : define-integer-ops ( word fix-word big-word -- ) [ @@ -138,7 +140,7 @@ SYMBOL: fast-math-ops [ drop math-class-max swap specific-method >boolean ] if ; : (derived-ops) ( word assoc -- words ) - swap [ rot first eq? nip ] curry assoc-filter ; + swap '[ swap first _ eq? nip ] assoc-filter ; : derived-ops ( word -- words ) [ 1array ] [ math-ops get (derived-ops) values ] bi append ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 2cb3d1f006..94a434f31b 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -307,7 +307,7 @@ M: object infer-call* \ { real real } { complex } define-primitive \ make-foldable -\ both-fixnums? { object object } { object object object } define-primitive +\ both-fixnums? { object object } { object } define-primitive \ fixnum+ { fixnum fixnum } { integer } define-primitive \ fixnum+ make-foldable diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 0a7e5fe233..f90ba23999 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -109,9 +109,6 @@ bootstrapping? on } [ create-vocab drop ] each ! Builtin classes -: define-builtin-predicate ( class -- ) - dup class>type [ builtin-instance? ] curry define-predicate ; - : lookup-type-number ( word -- n ) global [ target-word ] bind type-number ; @@ -192,6 +189,10 @@ define-union-class ] [ ] make define-predicate-class +"array-capacity" "sequences.private" lookup +[ >fixnum ] bootstrap-max-array-capacity [ fixnum-bitand ] curry append +"coercer" set-word-prop + ! Catch-all class for providing a default method. "object" "kernel" create [ f f { } intersection-class define-class ] diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor index ee687c2939..0e4a3b56fd 100644 --- a/core/classes/builtin/builtin.factor +++ b/core/classes/builtin/builtin.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors classes classes.algebra words kernel kernel.private namespaces sequences math math.private -combinators assocs ; +combinators assocs quotations ; IN: classes.builtin SYMBOL: builtins @@ -10,10 +10,14 @@ SYMBOL: builtins PREDICATE: builtin-class < class "metaclass" word-prop builtin-class eq? ; -: type>class ( n -- class ) builtins get-global nth ; - : class>type ( class -- n ) "type" word-prop ; foldable +PREDICATE: lo-tag-class < builtin-class class>type 7 <= ; + +PREDICATE: hi-tag-class < builtin-class class>type 7 > ; + +: type>class ( n -- class ) builtins get-global nth ; + : bootstrap-type>class ( n -- class ) builtins get nth ; M: hi-tag class hi-tag type>class ; @@ -22,16 +26,20 @@ M: object class tag type>class ; M: builtin-class rank-class drop 0 ; -: builtin-instance? ( object n -- ? ) - #! 7 == tag-mask get - #! 3 == hi-tag tag-number - dup 7 fixnum<= [ swap tag eq? ] [ - swap dup tag 3 eq? - [ hi-tag eq? ] [ 2drop f ] if - ] if ; inline +GENERIC: define-builtin-predicate ( class -- ) -M: builtin-class instance? - class>type builtin-instance? ; +M: lo-tag-class define-builtin-predicate + dup class>type [ eq? ] curry [ tag ] prepend define-predicate ; + +M: hi-tag-class define-builtin-predicate + dup class>type [ eq? ] curry [ hi-tag ] prepend 1quotation + [ dup tag 3 eq? ] [ [ drop f ] if ] surround + define-predicate ; + +M: lo-tag-class instance? [ tag ] [ class>type ] bi* eq? ; + +M: hi-tag-class instance? + over tag 3 eq? [ [ hi-tag ] [ class>type ] bi* eq? ] [ 2drop f ] if ; M: builtin-class (flatten-class) dup set ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 6f8021f733..9d748d665d 100644 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -90,10 +90,10 @@ ERROR: bad-superclass class ; 2drop f ] if ; inline -: tuple-instance-1? ( object class -- ? ) - swap dup tuple? [ - layout-of 7 slot eq? - ] [ 2drop f ] if ; inline +: tuple-predicate-quot/1 ( class -- quot ) + #! Fast path for tuples with no superclass + [ ] curry [ layout-of 7 slot ] [ eq? ] surround 1quotation + [ dup tuple? ] [ [ drop f ] if ] surround ; : tuple-instance? ( object class offset -- ? ) rot dup tuple? [ @@ -105,13 +105,16 @@ ERROR: bad-superclass class ; : layout-class-offset ( echelon -- n ) 2 * 5 + ; +: tuple-predicate-quot ( class echelon -- quot ) + layout-class-offset [ tuple-instance? ] 2curry ; + : echelon-of ( class -- n ) tuple-layout third ; : define-tuple-predicate ( class -- ) dup dup echelon-of { - { 1 [ [ tuple-instance-1? ] curry ] } - [ layout-class-offset [ tuple-instance? ] 2curry ] + { 1 [ tuple-predicate-quot/1 ] } + [ tuple-predicate-quot ] } case define-predicate ; : class-size ( class -- n ) diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 0acbdac8f8..63043b50b9 100644 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -83,7 +83,7 @@ M: math-combination perform-combination drop dup [ - \ both-fixnums? , + [ 2dup both-fixnums? ] % dup fixnum bootstrap-word dup math-method , \ over [ dup math-class? [ diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor index dbdc6e0742..5ed33009c0 100644 --- a/core/generic/standard/engines/tag/tag.factor +++ b/core/generic/standard/engines/tag/tag.factor @@ -3,7 +3,7 @@ USING: classes.private generic.standard.engines namespaces make arrays assocs sequences.private quotations kernel.private math slots.private math.private kernel accessors words -layouts sorting sequences ; +layouts sorting sequences combinators ; IN: generic.standard.engines.tag TUPLE: lo-tag-dispatch-engine methods ; @@ -24,15 +24,21 @@ C: lo-tag-dispatch-engine : sort-tags ( assoc -- alist ) >alist sort-keys reverse ; +: tag-dispatch-test ( tag# -- quot ) + picker [ tag ] append swap [ eq? ] curry append ; + +: tag-dispatch-quot ( alist -- quot ) + [ default get ] dip + [ [ tag-dispatch-test ] dip ] assoc-map + alist>quot ; + M: lo-tag-dispatch-engine engine>quot methods>> engines>quots* [ [ lo-tag-number ] dip ] assoc-map [ - picker % [ tag ] % [ - sort-tags linear-dispatch-quot - ] [ - num-tags get direct-dispatch-quot - ] if-small? % + [ sort-tags tag-dispatch-quot ] + [ picker % [ tag ] % num-tags get direct-dispatch-quot ] + if-small? % ] [ ] make ; TUPLE: hi-tag-dispatch-engine methods ; diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index 474cf4c9d6..a52ac65d18 100644 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -133,7 +133,7 @@ M: hashtable set-at ( value key hash -- ) : push-unsafe ( elt seq -- ) [ length ] keep [ underlying>> set-array-nth ] - [ [ 1+ ] dip (>>length) ] + [ [ 1 fixnum+fast { array-capacity } declare ] dip (>>length) ] 2bi ; inline PRIVATE> diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 98dc0e50fa..564600d322 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -154,8 +154,11 @@ TUPLE: identity-tuple ; M: identity-tuple equal? 2drop f ; +USE: math.private : = ( obj1 obj2 -- ? ) - 2dup eq? [ 2drop t ] [ equal? ] if ; inline + 2dup eq? [ 2drop t ] [ + 2dup both-fixnums? [ 2drop f ] [ equal? ] if + ] if ; inline GENERIC: clone ( obj -- cloned ) From 145b635eb60a265cf10cc6b88326108e95165e44 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Dec 2008 11:17:19 -0600 Subject: [PATCH 053/150] More optimization intended to reduce compile time. Another 10% speedup on compiling empty PEG parser - new map-flat combinator replaces usages of 'map flatten' in compiler - compiler.tree.def-use.simplified uses an explicit accumulator instead of flatten - compiler.tree.tuple-unboxing uses an explicit accumulator instead of flatten - fix inlining regression from last time: custom inlining results would sometimes be discarded - compiler.tree's 3each and 3map combinators rewritten to not use flip - rewrite math.partial-dispatch without locals (purely stylistic, no performance increase) - hand-optimize flip for common arrays-of-arrays case - don't run escape analysis and tuple unboxing if there are no allocations in the IR --- basis/bootstrap/compiler/compiler.factor | 2 +- .../cfg/two-operand/two-operand.factor | 4 +-- basis/compiler/tree/cleanup/cleanup.factor | 5 +-- .../tree/combinators/combinators.factor | 13 +++---- .../tree/dead-code/liveness/liveness.factor | 4 +-- .../tree/def-use/simplified/simplified.factor | 20 +++++------ .../escape-analysis/branches/branches.factor | 2 +- .../tree/escape-analysis/check/check.factor | 23 ++++++++++++ .../tree/normalization/normalization.factor | 7 ++-- .../compiler/tree/optimizer/optimizer.factor | 7 ++-- .../tree/propagation/branches/branches.factor | 7 ++-- .../tree/propagation/copy/copy.factor | 2 +- .../tree/propagation/inlining/inlining.factor | 29 ++++++++------- .../tree/propagation/propagation-tests.factor | 7 +++- .../tree/tuple-unboxing/tuple-unboxing.factor | 16 ++++++--- basis/compiler/utilities/utilities.factor | 31 ++++++++++++++++ .../partial-dispatch/partial-dispatch.factor | 20 +++++------ core/sequences/sequences.factor | 35 +++++++++++++++---- 18 files changed, 164 insertions(+), 70 deletions(-) create mode 100644 basis/compiler/tree/escape-analysis/check/check.factor create mode 100644 basis/compiler/utilities/utilities.factor diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index dabdeea741..9968af4330 100644 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -60,7 +60,7 @@ nl "." write flush { - new-sequence nth push pop peek + new-sequence nth push pop peek flip } compile-uncompiled "." write flush diff --git a/basis/compiler/cfg/two-operand/two-operand.factor b/basis/compiler/cfg/two-operand/two-operand.factor index e943fb4828..dabecaeec4 100644 --- a/basis/compiler/cfg/two-operand/two-operand.factor +++ b/basis/compiler/cfg/two-operand/two-operand.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays kernel sequences sequences.deep +USING: accessors arrays kernel sequences compiler.utilities compiler.cfg.instructions cpu.architecture ; IN: compiler.cfg.two-operand @@ -55,6 +55,6 @@ M: insn convert-two-operand* ; : convert-two-operand ( mr -- mr' ) [ two-operand? [ - [ convert-two-operand* ] map flatten + [ convert-two-operand* ] map-flat ] when ] change-instructions ; diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor index becac01cd5..1b0343faa9 100644 --- a/basis/compiler/tree/cleanup/cleanup.factor +++ b/basis/compiler/tree/cleanup/cleanup.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors sequences sequences.deep combinators fry +USING: kernel accessors sequences combinators fry classes.algebra namespaces assocs words math math.private math.partial-dispatch math.intervals classes classes.tuple classes.tuple.private layouts definitions stack-checker.state stack-checker.branches +compiler.utilities compiler.tree compiler.tree.combinators compiler.tree.propagation.info @@ -33,7 +34,7 @@ GENERIC: cleanup* ( node -- node/nodes ) : cleanup ( nodes -- nodes' ) #! We don't recurse into children here, instead the methods #! do it since the logic is a bit more involved - [ cleanup* ] map flatten ; + [ cleanup* ] map-flat ; : cleanup-folding? ( #call -- ? ) node-output-infos diff --git a/basis/compiler/tree/combinators/combinators.factor b/basis/compiler/tree/combinators/combinators.factor index 40bbf81a03..030df8484f 100644 --- a/basis/compiler/tree/combinators/combinators.factor +++ b/basis/compiler/tree/combinators/combinators.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs fry kernel accessors sequences sequences.deep arrays -stack-checker.inlining namespaces compiler.tree ; +USING: assocs fry kernel accessors sequences compiler.utilities +arrays stack-checker.inlining namespaces compiler.tree +math.order ; IN: compiler.tree.combinators : each-node ( nodes quot: ( node -- ) -- ) @@ -27,7 +28,7 @@ IN: compiler.tree.combinators [ _ map-nodes ] change-child ] when ] if - ] map flatten ; inline recursive + ] map-flat ; inline recursive : contains-node? ( nodes quot: ( node -- ? ) -- ? ) dup dup '[ @@ -48,12 +49,6 @@ IN: compiler.tree.combinators : sift-children ( seq flags -- seq' ) zip [ nip ] assoc-filter keys ; -: (3each) [ 3array flip ] dip '[ first3 @ ] ; inline - -: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline - -: 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline - : until-fixed-point ( #recursive quot: ( node -- ) -- ) over label>> t >>fixed-point drop [ with-scope ] 2keep diff --git a/basis/compiler/tree/dead-code/liveness/liveness.factor b/basis/compiler/tree/dead-code/liveness/liveness.factor index 44b71935c8..9ece5d340b 100644 --- a/basis/compiler/tree/dead-code/liveness/liveness.factor +++ b/basis/compiler/tree/dead-code/liveness/liveness.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors namespaces assocs deques search-deques -dlists kernel sequences sequences.deep words sets +dlists kernel sequences compiler.utilities words sets stack-checker.branches compiler.tree compiler.tree.def-use compiler.tree.combinators ; IN: compiler.tree.dead-code.liveness @@ -49,4 +49,4 @@ GENERIC: remove-dead-code* ( node -- node' ) M: node remove-dead-code* ; : (remove-dead-code) ( nodes -- nodes' ) - [ remove-dead-code* ] map flatten ; + [ remove-dead-code* ] map-flat ; diff --git a/basis/compiler/tree/def-use/simplified/simplified.factor b/basis/compiler/tree/def-use/simplified/simplified.factor index edfe633057..9b2a2038da 100644 --- a/basis/compiler/tree/def-use/simplified/simplified.factor +++ b/basis/compiler/tree/def-use/simplified/simplified.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: sequences sequences.deep kernel +USING: sequences kernel fry vectors compiler.tree compiler.tree.def-use ; IN: compiler.tree.def-use.simplified @@ -9,8 +9,6 @@ IN: compiler.tree.def-use.simplified ! A 'real' usage is a usage of a value that is not a #renaming. TUPLE: real-usage value node ; -GENERIC: actually-used-by* ( value node -- real-usages ) - ! Def GENERIC: actually-defined-by* ( value node -- real-usage ) @@ -25,16 +23,18 @@ M: #return-recursive actually-defined-by* real-usage boa ; M: node actually-defined-by* real-usage boa ; ! Use -: (actually-used-by) ( value -- real-usages ) - dup used-by [ actually-used-by* ] with map ; +GENERIC# actually-used-by* 1 ( value node accum -- ) + +: (actually-used-by) ( value accum -- ) + [ [ used-by ] keep ] dip '[ _ swap _ actually-used-by* ] each ; M: #renaming actually-used-by* - inputs/outputs [ indices ] dip nths - [ (actually-used-by) ] map ; + [ inputs/outputs [ indices ] dip nths ] dip + '[ _ (actually-used-by) ] each ; -M: #return-recursive actually-used-by* real-usage boa ; +M: #return-recursive actually-used-by* [ real-usage boa ] dip push ; -M: node actually-used-by* real-usage boa ; +M: node actually-used-by* [ real-usage boa ] dip push ; : actually-used-by ( value -- real-usages ) - (actually-used-by) flatten ; + 10 [ (actually-used-by) ] keep ; diff --git a/basis/compiler/tree/escape-analysis/branches/branches.factor b/basis/compiler/tree/escape-analysis/branches/branches.factor index b728e9a1ba..2eee3e698b 100644 --- a/basis/compiler/tree/escape-analysis/branches/branches.factor +++ b/basis/compiler/tree/escape-analysis/branches/branches.factor @@ -33,4 +33,4 @@ M: #branch escape-analysis* 2bi ; M: #phi escape-analysis* - [ phi-in-d>> ] [ out-d>> ] bi merge-allocations ; + [ phi-in-d>> flip ] [ out-d>> ] bi merge-allocations ; diff --git a/basis/compiler/tree/escape-analysis/check/check.factor b/basis/compiler/tree/escape-analysis/check/check.factor new file mode 100644 index 0000000000..333b3fa636 --- /dev/null +++ b/basis/compiler/tree/escape-analysis/check/check.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: classes classes.tuple math math.private accessors +combinators kernel compiler.tree compiler.tree.combinators +compiler.tree.propagation.info ; +IN: compiler.tree.escape-analysis.check + +GENERIC: run-escape-analysis* ( node -- ? ) + +M: #push run-escape-analysis* + literal>> [ class immutable-tuple-class? ] [ complex? ] bi or ; + +M: #call run-escape-analysis* + { + { [ dup word>> \ eq? ] [ t ] } + { [ dup immutable-tuple-boa? ] [ t ] } + [ f ] + } cond nip ; + +M: node run-escape-analysis* drop f ; + +: run-escape-analysis? ( nodes -- ? ) + [ run-escape-analysis* ] contains-node? ; diff --git a/basis/compiler/tree/normalization/normalization.factor b/basis/compiler/tree/normalization/normalization.factor index bebe2e91b6..8c13de296a 100644 --- a/basis/compiler/tree/normalization/normalization.factor +++ b/basis/compiler/tree/normalization/normalization.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry namespaces sequences math accessors kernel arrays -combinators sequences.deep assocs +combinators compiler.utilities assocs stack-checker.backend stack-checker.branches stack-checker.inlining +compiler.utilities compiler.tree compiler.tree.combinators compiler.tree.normalization.introductions @@ -46,7 +47,7 @@ M: #branch normalize* [ [ [ - [ normalize* ] map flatten + [ normalize* ] map-flat introduction-stack get 2array ] with-scope @@ -70,7 +71,7 @@ M: #phi normalize* : (normalize) ( nodes introductions -- nodes ) introduction-stack [ - [ normalize* ] map flatten + [ normalize* ] map-flat ] with-variable ; M: #recursive normalize* diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor index e37323a2ec..54c6c2c117 100644 --- a/basis/compiler/tree/optimizer/optimizer.factor +++ b/basis/compiler/tree/optimizer/optimizer.factor @@ -6,6 +6,7 @@ compiler.tree.normalization compiler.tree.propagation compiler.tree.cleanup compiler.tree.escape-analysis +compiler.tree.escape-analysis.check compiler.tree.tuple-unboxing compiler.tree.identities compiler.tree.def-use @@ -22,8 +23,10 @@ SYMBOL: check-optimizer? normalize propagate cleanup - escape-analysis - unbox-tuples + dup run-escape-analysis? [ + escape-analysis + unbox-tuples + ] when apply-identities compute-def-use remove-dead-code diff --git a/basis/compiler/tree/propagation/branches/branches.factor b/basis/compiler/tree/propagation/branches/branches.factor index 424cd8a01c..f2613022fc 100644 --- a/basis/compiler/tree/propagation/branches/branches.factor +++ b/basis/compiler/tree/propagation/branches/branches.factor @@ -3,6 +3,7 @@ USING: fry kernel sequences assocs accessors namespaces math.intervals arrays classes.algebra combinators columns stack-checker.branches +compiler.utilities compiler.tree compiler.tree.combinators compiler.tree.propagation.info @@ -78,7 +79,7 @@ SYMBOL: condition-value M: #phi propagate-before ( #phi -- ) [ annotate-phi-inputs ] - [ [ phi-info-d>> ] [ out-d>> ] bi merge-value-infos ] + [ [ phi-info-d>> flip ] [ out-d>> ] bi merge-value-infos ] bi ; : branch-phi-constraints ( output values booleans -- ) @@ -137,8 +138,8 @@ M: #phi propagate-before ( #phi -- ) M: #phi propagate-after ( #phi -- ) condition-value get [ [ out-d>> ] - [ phi-in-d>> ] - [ phi-info-d>> ] tri + [ phi-in-d>> flip ] + [ phi-info-d>> flip ] tri [ [ possible-boolean-values ] map branch-phi-constraints diff --git a/basis/compiler/tree/propagation/copy/copy.factor b/basis/compiler/tree/propagation/copy/copy.factor index 2452aba4aa..53b7d17326 100644 --- a/basis/compiler/tree/propagation/copy/copy.factor +++ b/basis/compiler/tree/propagation/copy/copy.factor @@ -49,7 +49,7 @@ M: #renaming compute-copy-equiv* inputs/outputs are-copies-of ; ] 2each ; M: #phi compute-copy-equiv* - [ phi-in-d>> ] [ out-d>> ] bi compute-phi-equiv ; + [ phi-in-d>> flip ] [ out-d>> ] bi compute-phi-equiv ; M: node compute-copy-equiv* drop ; diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 0e3b8431a6..fcc3b01dc0 100644 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -184,7 +184,7 @@ SYMBOL: history over in-d>> second value-info literal>> dup class? [ "predicate" word-prop '[ drop @ ] inline-word-def ] [ 3drop f ] if ; -: do-inlining ( #call word -- ? ) +: (do-inlining) ( #call word -- ? ) #! If the generic was defined in an outer compilation unit, #! then it doesn't have a definition yet; the definition #! is built at the end of the compilation unit. We do not @@ -193,14 +193,19 @@ SYMBOL: history #! of bounds value. This case comes up if a parsing word #! calls the compiler at parse time (doing so is #! discouraged, but it should still work.) - dup custom-inlining? [ 2dup inline-custom ] [ f ] if [ 2drop f ] [ - { - { [ dup deferred? ] [ 2drop f ] } - { [ dup \ instance? eq? ] [ inline-instance-check ] } - { [ dup always-inline-word? ] [ inline-word ] } - { [ dup standard-generic? ] [ inline-standard-method ] } - { [ dup math-generic? ] [ inline-math-method ] } - { [ dup method-body? ] [ inline-method-body ] } - [ 2drop f ] - } cond - ] if ; + { + { [ dup deferred? ] [ 2drop f ] } + { [ dup \ instance? eq? ] [ inline-instance-check ] } + { [ dup always-inline-word? ] [ inline-word ] } + { [ dup standard-generic? ] [ inline-standard-method ] } + { [ dup math-generic? ] [ inline-math-method ] } + { [ dup method-body? ] [ inline-method-body ] } + [ 2drop f ] + } cond ; + +: do-inlining ( #call word -- ? ) + #! Note the logic here: if there's a custom inlining hook, + #! it is permitted to return f, which means that we try the + #! normal inlining heuristic. + dup custom-inlining? [ 2dup inline-custom ] [ f ] if + [ 2drop t ] [ (do-inlining) ] if ; diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 2c4769abe0..aa04b58de7 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -8,7 +8,8 @@ math.functions math.private strings layouts compiler.tree.propagation.info compiler.tree.def-use compiler.tree.debugger compiler.tree.checker slots.private words hashtables classes assocs locals -specialized-arrays.double system sorting math.libm ; +specialized-arrays.double system sorting math.libm +math.intervals ; IN: compiler.tree.propagation.tests \ propagate must-infer @@ -599,6 +600,10 @@ MIXIN: empty-mixin [ V{ t } ] [ [ { fixnum } declare 10 mod >float -20 > ] final-literals ] unit-test +[ T{ interval f { 0 t } { 127 t } } ] [ + [ { integer } declare 127 bitand ] final-info first interval>> +] unit-test + ! [ V{ string } ] [ ! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes ! ] unit-test diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor index 52903fce8d..f6726e4404 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces assocs accessors kernel combinators -classes.algebra sequences sequences.deep slots.private +classes.algebra sequences slots.private fry vectors classes.tuple.private math math.private arrays stack-checker.branches +compiler.utilities compiler.tree compiler.tree.combinators compiler.tree.propagation.info @@ -21,7 +22,7 @@ GENERIC: unbox-tuples* ( node -- node/nodes ) : (expand-#push) ( object value -- nodes ) dup unboxed-allocation dup [ [ object-slots ] [ drop ] [ ] tri* - [ (expand-#push) ] 2map + [ (expand-#push) ] 2map-flat ] [ drop #push ] if ; @@ -38,11 +39,16 @@ M: #push unbox-tuples* ( #push -- nodes ) : unbox- ( #call -- nodes ) dup unbox-output? [ drop { } ] when ; -: (flatten-values) ( values -- values' ) - [ dup unboxed-allocation [ (flatten-values) ] [ ] ?if ] map ; +: (flatten-values) ( values accum -- ) + dup '[ + dup unboxed-allocation + [ _ (flatten-values) ] [ _ push ] ?if + ] each ; : flatten-values ( values -- values' ) - dup empty? [ (flatten-values) flatten ] unless ; + dup empty? [ + 10 [ (flatten-values) ] keep + ] unless ; : prepare-slot-access ( #call -- tuple-values outputs slot-values ) [ in-d>> flatten-values ] diff --git a/basis/compiler/utilities/utilities.factor b/basis/compiler/utilities/utilities.factor new file mode 100644 index 0000000000..1f488b3dde --- /dev/null +++ b/basis/compiler/utilities/utilities.factor @@ -0,0 +1,31 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences sequences.private arrays vectors fry +math.order ; +IN: compiler.utilities + +: flattener ( seq quot -- seq vector quot' ) + over length [ + dup + '[ + @ [ + dup array? + [ _ push-all ] [ _ push ] if + ] when* + ] + ] keep ; inline + +: flattening ( seq quot combinator -- seq' ) + [ flattener ] dip dip { } like ; inline + +: map-flat ( seq quot -- seq' ) [ each ] flattening ; inline + +: 2map-flat ( seq quot -- seq' ) [ 2each ] flattening ; inline + +: (3each) ( seq1 seq2 seq3 quot -- n quot' ) + [ [ [ length ] tri@ min min ] 3keep ] dip + '[ [ _ nth-unsafe ] [ _ nth-unsafe ] [ _ nth-unsafe ] tri @ ] ; inline + +: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline + +: 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline diff --git a/basis/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor index bfa127e7e0..19715357ee 100644 --- a/basis/math/partial-dispatch/partial-dispatch.factor +++ b/basis/math/partial-dispatch/partial-dispatch.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel kernel.private math math.private words -sequences parser namespaces make assocs quotations arrays locals +sequences parser namespaces make assocs quotations arrays generic generic.math hashtables effects compiler.units classes.algebra fry combinators ; IN: math.partial-dispatch @@ -45,29 +45,29 @@ M: word integer-op-input-classes { bitnot fixnum-bitnot } } at swap or ; -:: integer-fixnum-op-quot ( fix-word big-word -- quot ) +: integer-fixnum-op-quot ( fix-word big-word -- quot ) [ [ over fixnum? ] % - fix-word '[ _ execute ] , - big-word '[ fixnum>bignum _ execute ] , + [ '[ _ execute ] , ] + [ '[ fixnum>bignum _ execute ] , ] bi* \ if , ] [ ] make ; -:: fixnum-integer-op-quot ( fix-word big-word -- quot ) +: fixnum-integer-op-quot ( fix-word big-word -- quot ) [ [ dup fixnum? ] % - fix-word '[ _ execute ] , - big-word '[ [ fixnum>bignum ] dip _ execute ] , + [ '[ _ execute ] , ] + [ '[ [ fixnum>bignum ] dip _ execute ] , ] bi* \ if , ] [ ] make ; -:: integer-integer-op-quot ( fix-word big-word -- quot ) +: integer-integer-op-quot ( fix-word big-word -- quot ) [ [ dup fixnum? ] % - fix-word big-word integer-fixnum-op-quot , + 2dup integer-fixnum-op-quot , [ [ over fixnum? [ [ fixnum>bignum ] dip ] when ] % - big-word , + nip , ] [ ] make , \ if , ] [ ] make ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 3461266081..995a8bba4c 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -835,12 +835,35 @@ PRIVATE> : supremum ( seq -- n ) dup first [ max ] reduce ; -: flip ( matrix -- newmatrix ) - dup empty? [ - dup [ length ] map infimum - swap [ [ nth-unsafe ] with { } map-as ] curry { } map-as - ] unless ; - : sigma ( seq quot -- n ) [ + ] compose 0 swap reduce ; inline : count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline + +! We hand-optimize flip to such a degree because type hints +! cannot express that an array is an array of arrays yet, and +! this word happens to be performance-critical since the compiler +! itself uses it. Optimizing it like this reduced compile time. +> ; + +: array-flip ( matrix -- newmatrix ) + [ dup first array-length [ array-length min ] reduce ] keep + [ [ array-nth ] with { } map-as ] curry { } map-as ; + +PRIVATE> + +: flip ( matrix -- newmatrix ) + dup empty? [ + dup array? [ + dup [ array? ] all? + [ array-flip ] [ generic-flip ] if + ] [ generic-flip ] if + ] unless ; From 9c2e8abaca27d424600dc57f299d2f43adbf9eeb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Dec 2008 14:24:31 -0600 Subject: [PATCH 054/150] Enable more local DCE --- basis/stack-checker/known-words/known-words.factor | 3 --- 1 file changed, 3 deletions(-) diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 94a434f31b..28634f2d44 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -99,21 +99,18 @@ M: object infer-call* 3 infer->r infer-call 3 infer-r> ; : infer-dip ( -- ) - commit-literals literals get [ \ dip def>> infer-quot-here ] [ pop 1 infer->r infer-quot-here 1 infer-r> ] if-empty ; : infer-2dip ( -- ) - commit-literals literals get [ \ 2dip def>> infer-quot-here ] [ pop 2 infer->r infer-quot-here 2 infer-r> ] if-empty ; : infer-3dip ( -- ) - commit-literals literals get [ \ 3dip def>> infer-quot-here ] [ pop 3 infer->r infer-quot-here 3 infer-r> ] From 03dd5db902072ef3046367b308f08a1f85621d29 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Dec 2008 14:24:44 -0600 Subject: [PATCH 055/150] Documentation update --- basis/concurrency/messaging/messaging-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/concurrency/messaging/messaging-docs.factor b/basis/concurrency/messaging/messaging-docs.factor index 25538cd594..44ca6df269 100644 --- a/basis/concurrency/messaging/messaging-docs.factor +++ b/basis/concurrency/messaging/messaging-docs.factor @@ -74,9 +74,9 @@ ARTICLE: { "concurrency" "exceptions" } "Linked exceptions" "Exceptions are only raised in the parent when the parent does a " { $link receive } " or " { $link receive-if } ". This is because the exception is sent from the child to the parent as a message." ; ARTICLE: "concurrency.messaging" "Message-passing concurrency" -"The " { $vocab-link "concurrency.messaging" } " vocabulary is based upon the style of concurrency used in systems like Erlang and Termite. It is built on top of the standard Factor lightweight thread system." +"The " { $vocab-link "concurrency.messaging" } " vocabulary is based upon the style of concurrency used in systems like Erlang and Termite. It is built on top of " { $link "threads" } "." $nl -"A concurrency oriented program is one in which multiple threades run simultaneously in a single Factor image or across multiple running Factor instances. The threades can communicate with each other by asynchronous message sends." +"A concurrency-oriented program is one in which multiple threads run simultaneously in a single Factor image or across multiple running Factor instances. The threades can communicate with each other by asynchronous message sends." $nl "Although threades can share data via Factor's mutable data structures it is not recommended to mix shared state with message passing as it can lead to confusing code." { $subsection { "concurrency" "messaging" } } From b256539500e7830a66eb2597d66222893c59313b Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 6 Dec 2008 15:03:02 -0600 Subject: [PATCH 056/150] ui.gadgets.sliders: Rewrite 'slider-scale' to not use shuffle words --- basis/ui/gadgets/sliders/sliders.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/basis/ui/gadgets/sliders/sliders.factor b/basis/ui/gadgets/sliders/sliders.factor index 9e13e5ad7c..1c2055156e 100644 --- a/basis/ui/gadgets/sliders/sliders.factor +++ b/basis/ui/gadgets/sliders/sliders.factor @@ -36,8 +36,9 @@ TUPLE: slider < frame elevator thumb saved line ; #! A scaling factor such that if x is a slider co-ordinate, #! x*n is the screen position of the thumb, and conversely #! for x/n. The '1 max' calls avoid division by zero. - dup elevator-length over thumb-dim - 1 max - swap slider-max* 1 max / ; + [ [ elevator-length ] [ thumb-dim ] bi - 1 max ] + [ slider-max* 1 max ] + bi / ; : slider>screen ( m scale -- n ) slider-scale * ; : screen>slider ( m scale -- n ) slider-scale / ; From ebf0f27773caf065b4b78837b852fe81084de5bc Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 6 Dec 2008 15:12:59 -0600 Subject: [PATCH 057/150] concurrency.messaging-docs: Use consistent spelling for 'threads'. --- basis/concurrency/messaging/messaging-docs.factor | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/basis/concurrency/messaging/messaging-docs.factor b/basis/concurrency/messaging/messaging-docs.factor index 44ca6df269..3bd2d330c3 100644 --- a/basis/concurrency/messaging/messaging-docs.factor +++ b/basis/concurrency/messaging/messaging-docs.factor @@ -8,20 +8,20 @@ HELP: send { $values { "message" object } { "thread" thread } } -{ $description "Send the message to the thread by placing it in the threades mailbox. This is an asynchronous operation and will return immediately. The receving thread will act on the message the next time it retrieves that item from its mailbox (usually using the " { $link receive } " word. The message can be any Factor object. For destinations that are instances of remote-thread the message must be a serializable Factor type." } +{ $description "Send the message to the thread by placing it in the threads mailbox. This is an asynchronous operation and will return immediately. The receving thread will act on the message the next time it retrieves that item from its mailbox (usually using the " { $link receive } " word. The message can be any Factor object. For destinations that are instances of remote-thread the message must be a serializable Factor type." } { $see-also receive receive-if } ; HELP: receive { $values { "message" object } } -{ $description "Return a message from the current threades mailbox. If the box is empty, suspend the thread until another thread places an item in the mailbox (usually via the " { $link send } " word." } +{ $description "Return a message from the current threads mailbox. If the box is empty, suspend the thread until another thread places an item in the mailbox (usually via the " { $link send } " word." } { $see-also send receive-if } ; HELP: receive-if { $values { "pred" "a predicate with stack effect " { $snippet "( obj -- ? )" } } { "message" object } } -{ $description "Return the first message from the current threades mailbox that satisfies the predicate. To satisfy the predicate, " { $snippet "pred" } " is called with the item on the stack and the predicate should leave a boolean indicating whether it was satisfied or not. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } +{ $description "Return the first message from the current threads mailbox that satisfies the predicate. To satisfy the predicate, " { $snippet "pred" } " is called with the item on the stack and the predicate should leave a boolean indicating whether it was satisfied or not. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } { $see-also send receive } ; HELP: spawn-linked @@ -29,7 +29,7 @@ HELP: spawn-linked { "name" string } { "thread" thread } } -{ $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threades that restart child threades that crash due to uncaught errors.\n" } +{ $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threads that restart child threads that crash due to uncaught errors.\n" } { $see-also spawn } ; ARTICLE: { "concurrency" "messaging" } "Sending and receiving messages" @@ -64,7 +64,7 @@ ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends" ARTICLE: { "concurrency" "exceptions" } "Linked exceptions" "A thread can handle exceptions using the standard Factor exception handling mechanism. If an exception is uncaught the thread will terminate. For example:" { $code "[ 1 0 / \"This will not print\" print ] \"division-by-zero\" spawn" } -"Processes can be linked so that a parent thread can receive the exception that caused the child thread to terminate. In this way 'supervisor' threades can be created that are notified when child threades terminate and possibly restart them." +"Processes can be linked so that a parent thread can receive the exception that caused the child thread to terminate. In this way 'supervisor' threads can be created that are notified when child threads terminate and possibly restart them." { $subsection spawn-linked } "This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent thread can catch it:" { $code "[" @@ -76,9 +76,9 @@ ARTICLE: { "concurrency" "exceptions" } "Linked exceptions" ARTICLE: "concurrency.messaging" "Message-passing concurrency" "The " { $vocab-link "concurrency.messaging" } " vocabulary is based upon the style of concurrency used in systems like Erlang and Termite. It is built on top of " { $link "threads" } "." $nl -"A concurrency-oriented program is one in which multiple threads run simultaneously in a single Factor image or across multiple running Factor instances. The threades can communicate with each other by asynchronous message sends." +"A concurrency-oriented program is one in which multiple threads run simultaneously in a single Factor image or across multiple running Factor instances. The threads can communicate with each other by asynchronous message sends." $nl -"Although threades can share data via Factor's mutable data structures it is not recommended to mix shared state with message passing as it can lead to confusing code." +"Although threads can share data via Factor's mutable data structures it is not recommended to mix shared state with message passing as it can lead to confusing code." { $subsection { "concurrency" "messaging" } } { $subsection { "concurrency" "synchronous-sends" } } { $subsection { "concurrency" "exceptions" } } ; From d2ce4355f8bfd5e055688d2bc5c22d105221bc3b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Dec 2008 15:30:40 -0600 Subject: [PATCH 058/150] Fixing PPC backend --- basis/cpu/ppc/ppc.factor | 23 ++++++++++------------- 1 file changed, 10 insertions(+), 13 deletions(-) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 46986dc5e6..c555c4b809 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -37,8 +37,8 @@ M: ppc %load-immediate ( reg n -- ) swap LOAD ; M: ppc %load-indirect ( reg obj -- ) [ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-immediate ] bi* ; -: %load-dlsym ( symbol dll register -- ) - 0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ; +M: ppc %alien-global ( register symbol dll -- ) + [ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ; : ds-reg 29 ; inline : rs-reg 30 ; inline @@ -145,8 +145,8 @@ M:: ppc %string-nth ( dst src index temp -- ) temp temp index ADD temp temp index ADD temp temp byte-array-offset LHZ - temp temp 8 SLWI - dst dst temp OR + temp temp 7 SLWI + dst dst temp XOR "end" resolve-label ] with-scope ; @@ -172,7 +172,7 @@ M: ppc %sar-imm SRAWI ; M: ppc %not NOT ; : %alien-invoke-tail ( func dll -- ) - scratch-reg %load-dlsym scratch-reg MTCTR BCTR ; + [ scratch-reg ] 2dip %alien-global scratch-reg MTCTR BCTR ; :: exchange-regs ( r1 r2 -- ) scratch-reg r1 MR @@ -411,7 +411,7 @@ M: ppc %set-alien-float swap 0 STFS ; M: ppc %set-alien-double swap 0 STFD ; : load-zone-ptr ( reg -- ) - [ "nursery" f ] dip %load-dlsym ; + "nursery" f %alien-global ; : load-allot-ptr ( nursery-ptr allot-ptr -- ) [ drop load-zone-ptr ] [ swap 4 LWZ ] 2bi ; @@ -433,14 +433,11 @@ M:: ppc %allot ( dst size class nursery-ptr -- ) dst class store-header dst class store-tagged ; -: %alien-global ( dst name -- ) - [ f rot %load-dlsym ] [ drop dup 0 LWZ ] 2bi ; - : load-cards-offset ( dst -- ) - "cards_offset" %alien-global ; + [ "cards_offset" f %alien-global ] [ dup 0 LWZ ] bi ; : load-decks-offset ( dst -- ) - "decks_offset" %alien-global ; + [ "decks_offset" f %alien-global ] [ dup 0 LWZ ] bi ; M:: ppc %write-barrier ( src card# table -- ) card-mark scratch-reg LI @@ -627,14 +624,14 @@ M: ppc %prepare-alien-invoke #! Save Factor stack pointers in case the C code calls a #! callback which does a GC, which must reliably trace #! all roots. - "stack_chain" f scratch-reg %load-dlsym + scratch-reg "stack_chain" f %alien-global scratch-reg scratch-reg 0 LWZ 1 scratch-reg 0 STW ds-reg scratch-reg 8 STW rs-reg scratch-reg 12 STW ; M: ppc %alien-invoke ( symbol dll -- ) - 11 %load-dlsym 11 MTLR BLRL ; + [ 11 ] 2dip %alien-global 11 MTLR BLRL ; M: ppc %alien-callback ( quot -- ) 3 swap %load-indirect "c_to_factor" f %alien-invoke ; From 8a8f0c925c80907199c56a7aab60fea75ff18a59 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Dec 2008 15:31:17 -0600 Subject: [PATCH 059/150] Use BSR instruction to implement fixnum-log2 intrinsic --- basis/compiler/cfg/hats/hats.factor | 1 + basis/compiler/cfg/instructions/instructions.factor | 1 + basis/compiler/cfg/intrinsics/fixnum/fixnum.factor | 3 +++ basis/compiler/cfg/intrinsics/intrinsics.factor | 5 +++++ basis/compiler/codegen/codegen.factor | 1 + basis/cpu/architecture/architecture.factor | 1 + basis/cpu/x86/assembler/assembler.factor | 2 ++ basis/cpu/x86/x86.factor | 7 +++++-- core/math/integers/integers.factor | 10 ++++++---- core/math/math.factor | 11 +++-------- 10 files changed, 28 insertions(+), 14 deletions(-) diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index ca793de1b7..c0d5bf79a6 100644 --- a/basis/compiler/cfg/hats/hats.factor +++ b/basis/compiler/cfg/hats/hats.factor @@ -39,6 +39,7 @@ IN: compiler.cfg.hats : ^^shr-imm ( src1 src2 -- dst ) ^^i2 ##shr-imm ; inline : ^^sar-imm ( src1 src2 -- dst ) ^^i2 ##sar-imm ; inline : ^^not ( src -- dst ) ^^i1 ##not ; inline +: ^^log2 ( src -- dst ) ^^i1 ##log2 ; inline : ^^bignum>integer ( src -- dst ) ^^i1 i ##bignum>integer ; inline : ^^integer>bignum ( src -- dst ) ^^i1 i ##integer>bignum ; inline : ^^add-float ( src1 src2 -- dst ) ^^d2 ##add-float ; inline diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index b34e5f8232..5619a70740 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -92,6 +92,7 @@ INSN: ##shl-imm < ##binary-imm ; INSN: ##shr-imm < ##binary-imm ; INSN: ##sar-imm < ##binary-imm ; INSN: ##not < ##unary ; +INSN: ##log2 < ##unary ; ! Overflowing arithmetic TUPLE: ##fixnum-overflow < insn src1 src2 ; diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor index 69cd5e5669..3ad716d847 100644 --- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor +++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor @@ -53,6 +53,9 @@ IN: compiler.cfg.intrinsics.fixnum : emit-fixnum-bitnot ( -- ) ds-pop ^^not tag-mask get ^^xor-imm ds-push ; +: emit-fixnum-log2 ( -- ) + ds-pop ^^log2 tag-bits get ^^sub-imm ^^tag-fixnum ds-push ; + : (emit-fixnum*fast) ( -- dst ) 2inputs ^^untag-fixnum ^^mul ; diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 41f4bf47a5..6656cd11f7 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -19,6 +19,7 @@ QUALIFIED: slots.private QUALIFIED: strings.private QUALIFIED: classes.tuple.private QUALIFIED: math.private +QUALIFIED: math.integers.private QUALIFIED: alien.accessors IN: compiler.cfg.intrinsics @@ -93,6 +94,9 @@ IN: compiler.cfg.intrinsics alien.accessors:set-alien-double } [ t "intrinsic" set-word-prop ] each ; +: enable-fixnum-log2 ( -- ) + \ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ; + : emit-intrinsic ( node word -- node/f ) { { \ kernel.private:tag [ drop emit-tag iterate-next ] } @@ -108,6 +112,7 @@ IN: compiler.cfg.intrinsics { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op iterate-next ] } { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast iterate-next ] } { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot iterate-next ] } + { \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 iterate-next ] } { \ math.private:fixnum*fast [ emit-fixnum*fast iterate-next ] } { \ math.private:fixnum< [ cc< emit-fixnum-comparison iterate-next ] } { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison iterate-next ] } diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index fe3da93130..9f134c02d7 100644 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -163,6 +163,7 @@ M: ##shl-imm generate-insn dst/src1/src2 %shl-imm ; M: ##shr-imm generate-insn dst/src1/src2 %shr-imm ; M: ##sar-imm generate-insn dst/src1/src2 %sar-imm ; M: ##not generate-insn dst/src %not ; +M: ##log2 generate-insn dst/src %log2 ; : src1/src2 ( insn -- src1 src2 ) [ src1>> register ] [ src2>> register ] bi ; inline diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 836385574d..c609b9e98d 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -77,6 +77,7 @@ HOOK: %shl-imm cpu ( dst src1 src2 -- ) HOOK: %shr-imm cpu ( dst src1 src2 -- ) HOOK: %sar-imm cpu ( dst src1 src2 -- ) HOOK: %not cpu ( dst src -- ) +HOOK: %log2 cpu ( dst src -- ) HOOK: %fixnum-add cpu ( src1 src2 -- ) HOOK: %fixnum-add-tail cpu ( src1 src2 -- ) diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index 27c00cb3c0..2bea887295 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -384,6 +384,8 @@ M: operand CMP OCT: 070 2-operand ; : XCHG ( dst src -- ) OCT: 207 2-operand ; +: BSR ( dst src -- ) swap { HEX: 0f HEX: bd } (2-operand) ; + : NOT ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ; : NEG ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ; : MUL ( dst -- ) { BIN: 100 t HEX: f7 } 1-operand ; diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index c477e98aa7..44300a75f9 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -5,10 +5,12 @@ cpu.x86.assembler cpu.x86.assembler.private cpu.architecture kernel kernel.private math memory namespaces make sequences words system layouts combinators math.order fry locals compiler.constants compiler.cfg.registers -compiler.cfg.instructions compiler.codegen -compiler.codegen.fixup ; +compiler.cfg.instructions compiler.cfg.intrinsics +compiler.codegen compiler.codegen.fixup ; IN: cpu.x86 +<< enable-fixnum-log2 >> + M: x86 two-operand? t ; HOOK: temp-reg-1 cpu ( -- reg ) @@ -92,6 +94,7 @@ M: x86 %shl-imm nip SHL ; M: x86 %shr-imm nip SHR ; M: x86 %sar-imm nip SAR ; M: x86 %not drop NOT ; +M: x86 %log2 BSR ; : ?MOV ( dst src -- ) 2dup = [ 2drop ] [ MOV ] if ; inline diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index fcb1b65d80..910d394c55 100644 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -40,11 +40,13 @@ M: fixnum bitnot fixnum-bitnot ; M: fixnum bit? neg shift 1 bitand 0 > ; -: (fixnum-log2) ( accum n -- accum ) - dup 1 number= [ drop ] [ [ 1+ ] [ 2/ ] bi* (fixnum-log2) ] if ; - inline recursive +: fixnum-log2 ( x -- n ) + 0 swap [ dup 1 number= not ] [ [ 1+ ] [ 2/ ] bi* ] [ ] while drop ; -M: fixnum (log2) 0 swap (fixnum-log2) ; +M: fixnum (log2) fixnum-log2 ; + +M: integer next-power-of-2 + dup 2 <= [ drop 2 ] [ 1- log2 1+ 2^ ] if ; M: bignum >fixnum bignum>fixnum ; M: bignum >bignum ; diff --git a/core/math/math.factor b/core/math/math.factor index 5c53d99cff..8b064725d3 100644 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -53,7 +53,7 @@ PRIVATE> "log2 expects positive inputs" throw ] [ (log2) - ] if ; foldable + ] if ; inline : zero? ( x -- ? ) 0 number= ; inline : 1+ ( x -- y ) 1 + ; inline @@ -103,14 +103,9 @@ M: float fp-infinity? ( float -- ? ) drop f ] if ; -: (next-power-of-2) ( i n -- n ) - 2dup >= [ - drop - ] [ - [ 1 shift ] dip (next-power-of-2) - ] if ; +GENERIC: next-power-of-2 ( m -- n ) foldable -: next-power-of-2 ( m -- n ) 2 swap (next-power-of-2) ; foldable +M: real next-power-of-2 1+ >integer next-power-of-2 ; : power-of-2? ( n -- ? ) dup 0 <= [ drop f ] [ dup 1- bitand zero? ] if ; foldable From bac338663da5965245c686e10537a97b76d9b38c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Dec 2008 15:31:35 -0600 Subject: [PATCH 060/150] Mark a word inline --- core/hashtables/hashtables.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index a52ac65d18..8663f25a70 100644 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -40,7 +40,7 @@ TUPLE: hashtable 0 >>count 0 >>deleted drop ; inline : reset-hash ( n hash -- ) - swap >>array init-hash ; + swap >>array init-hash ; inline : (new-key@) ( key keys i -- keys n empty? ) 3dup swap array-nth dup ((empty)) eq? [ From 0359ec8eac4c3356f74302aa393d3c060a59a669 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Dec 2008 16:57:28 -0600 Subject: [PATCH 061/150] Fix PowerPC backend again --- basis/cpu/ppc/bootstrap.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index d22ff4d615..445c7082bc 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -329,14 +329,15 @@ big-endian on ! Math [ 3 ds-reg 0 LWZ - 4 ds-reg -4 LWZ + ds-reg ds-reg 4 SUBI + 4 ds-reg 0 LWZ 3 3 4 OR 3 3 tag-mask get ANDI \ f tag-number 4 LI 0 3 0 CMPI 2 BNE 1 tag-fixnum 4 LI - 4 ds-reg 4 STWU + 4 ds-reg 0 STW ] f f f \ both-fixnums? define-sub-primitive : jit-math ( insn -- ) From d84d267948770ce436b7951a17a5c63d84a55d85 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Dec 2008 17:35:04 -0600 Subject: [PATCH 062/150] Add some CFFileDescriptor-related functions --- basis/core-foundation/core-foundation.factor | 24 +++++++++++++++++++ .../core-foundation/run-loop/run-loop.factor | 13 ++++++++++ 2 files changed, 37 insertions(+) diff --git a/basis/core-foundation/core-foundation.factor b/basis/core-foundation/core-foundation.factor index 8e5051e75d..d63a66dbe7 100644 --- a/basis/core-foundation/core-foundation.factor +++ b/basis/core-foundation/core-foundation.factor @@ -16,13 +16,17 @@ TYPEDEF: void* CFStringRef TYPEDEF: void* CFURLRef TYPEDEF: void* CFUUIDRef TYPEDEF: void* CFTypeRef +TYPEDEF: void* CFFileDescriptorRef TYPEDEF: bool Boolean TYPEDEF: long CFIndex TYPEDEF: int SInt32 TYPEDEF: uint UInt32 TYPEDEF: ulong CFTypeID +TYPEDEF: UInt32 CFOptionFlags TYPEDEF: double CFTimeInterval TYPEDEF: double CFAbsoluteTime +TYPEDEF: int CFFileDescriptorNativeDescriptor +TYPEDEF: void* CFFileDescriptorCallBack TYPEDEF: int CFNumberType : kCFNumberSInt8Type 1 ; inline @@ -121,18 +125,35 @@ FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ; ] keep CFRelease ; GENERIC: ( number -- alien ) + M: integer [ f kCFNumberLongLongType ] dip CFNumberCreate ; + M: float [ f kCFNumberDoubleType ] dip CFNumberCreate ; + M: t drop f kCFNumberIntType 1 CFNumberCreate ; + M: f drop f kCFNumberIntType 0 CFNumberCreate ; : ( byte-array -- alien ) [ f ] dip dup length CFDataCreate ; +FUNCTION: CFFileDescriptorRef CFFileDescriptorCreate ( + CFAllocatorRef allocator, + CFFileDescriptorNativeDescriptor fd, + Boolean closeOnInvalidate, + CFFileDescriptorCallBack callout, + CFFileDescriptorContext* context +) ; + +FUNCTION: void CFFileDescriptorEnableCallBacks ( + CFFileDescriptorRef f, + CFOptionFlags callBackTypes +) ; + : load-framework ( name -- ) dup [ CFBundleLoadExecutable drop @@ -141,8 +162,11 @@ M: f ] ?if ; TUPLE: CFRelease-destructor alien disposed ; + M: CFRelease-destructor dispose* alien>> CFRelease ; + : &CFRelease ( alien -- alien ) dup f CFRelease-destructor boa &dispose drop ; inline + : |CFRelease ( alien -- alien ) dup f CFRelease-destructor boa |dispose drop ; inline diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor index 9a5666b5d3..c334297122 100644 --- a/basis/core-foundation/run-loop/run-loop.factor +++ b/basis/core-foundation/run-loop/run-loop.factor @@ -10,6 +10,7 @@ IN: core-foundation.run-loop : kCFRunLoopRunHandledSource 4 ; inline TYPEDEF: void* CFRunLoopRef +TYPEDEF: void* CFRunLoopSourceRef FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ; FUNCTION: CFRunLoopRef CFRunLoopGetCurrent ( ) ; @@ -20,6 +21,18 @@ FUNCTION: SInt32 CFRunLoopRunInMode ( Boolean returnAfterSourceHandled ) ; +FUNCTION: CFRunLoopSourceRef CFFileDescriptorCreateRunLoopSource ( + CFAllocatorRef allocator, + CFFileDescriptorRef f, + CFIndex order +) ; + +FUNCTION: void CFRunLoopAddSource ( + CFRunLoopRef rl, + CFRunLoopSourceRef source, + CFStringRef mode +) ; + : CFRunLoopDefaultMode ( -- alien ) #! Ugly, but we don't have static NSStrings \ CFRunLoopDefaultMode get-global dup expired? [ From d62e867db3c620cbd90991d40fc2d910fca15a1d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Dec 2008 17:35:15 -0600 Subject: [PATCH 063/150] Dusting off old kqueue code --- basis/io/unix/kqueue/kqueue.factor | 166 +++++++++-------------------- 1 file changed, 49 insertions(+), 117 deletions(-) diff --git a/basis/io/unix/kqueue/kqueue.factor b/basis/io/unix/kqueue/kqueue.factor index ba4240de7f..6b687a8afb 100644 --- a/basis/io/unix/kqueue/kqueue.factor +++ b/basis/io/unix/kqueue/kqueue.factor @@ -1,11 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types kernel math math.bitwise namespaces -locals accessors combinators threads vectors hashtables -sequences assocs continuations sets -unix unix.time unix.kqueue unix.process -io.ports io.unix.backend io.launcher io.unix.launcher -io.monitors ; +USING: accessors alien.c-types combinators io.unix.backend +kernel math.bitwise sequences struct-arrays unix unix.kqueue +unix.time ; IN: io.unix.kqueue TUPLE: kqueue-mx < mx events monitors ; @@ -19,131 +16,66 @@ TUPLE: kqueue-mx < mx events monitors ; kqueue-mx new-mx H{ } clone >>monitors kqueue dup io-error >>fd - max-events "kevent" >>events ; + max-events "kevent" >>events ; -GENERIC: io-task-filter ( task -- n ) - -M: input-task io-task-filter drop EVFILT_READ ; - -M: output-task io-task-filter drop EVFILT_WRITE ; - -GENERIC: io-task-fflags ( task -- n ) - -M: io-task io-task-fflags drop 0 ; - -: make-kevent ( task flags -- event ) +: make-kevent ( fd filter flags -- event ) "kevent" - tuck set-kevent-flags - over io-task-fd over set-kevent-ident - over io-task-fflags over set-kevent-fflags - swap io-task-filter over set-kevent-filter ; + [ set-kevent-flags ] keep + [ set-kevent-filter ] keep + [ set-kevent-ident ] keep ; : register-kevent ( kevent mx -- ) - fd>> swap 1 f 0 f kevent - 0 < [ err_no ESRCH = [ (io-error) ] unless ] when ; + fd>> swap 1 f 0 f kevent io-error ; -M: kqueue-mx register-io-task ( task mx -- ) - [ >r EV_ADD make-kevent r> register-kevent ] - [ call-next-method ] - 2bi ; +M: kqueue-mx add-input-callback ( thread fd mx -- ) + [ call-next-method ] [ + [ EVFILT_READ { EV_ADD EV_ONESHOT } flags make-kevent ] dip + register-kevent + ] 2bi ; -M: kqueue-mx unregister-io-task ( task mx -- ) - [ call-next-method ] - [ >r EV_DELETE make-kevent r> register-kevent ] - 2bi ; +M: kqueue-mx add-output-callback ( thread fd mx -- ) + [ call-next-method ] [ + [ EVFILT_WRITE EV_DELETE make-kevent ] dip + register-kevent + ] 2bi ; + +: cancel-input-callbacks ( fd mx -- seq ) + [ + [ EVFILT_READ EV_DELETE make-kevent ] dip + register-kevent + ] [ remove-input-callbacks ] 2bi ; + +: cancel-output-callbacks ( fd mx -- seq ) + [ + [ EVFILT_WRITE EV_DELETE make-kevent ] dip + register-kevent + ] [ remove-output-callbacks ] 2bi ; + +M: fd cancel-operation ( fd -- ) + dup disposed>> [ drop ] [ + fd>> + mx get-global + [ cancel-input-callbacks [ t swap resume-with ] each ] + [ cancel-output-callbacks [ t swap resume-with ] each ] + 2bi + ] if ; : wait-kevent ( mx timespec -- n ) - >r [ fd>> f 0 ] keep events>> max-events r> kevent + [ + [ fd>> f 0 ] + [ events>> [ underlying>> ] [ length ] bi ] bi + ] dip kevent dup multiplexer-error ; -:: kevent-read-task ( mx fd kevent -- ) - mx fd mx reads>> at perform-io-task ; - -:: kevent-write-task ( mx fd kevent -- ) - mx fd mx writes>> at perform-io-task ; - -:: kevent-proc-task ( mx pid kevent -- ) - pid wait-for-pid - pid find-process - dup [ swap notify-exit ] [ 2drop ] if ; - -: parse-action ( mask -- changed ) - [ - NOTE_DELETE +remove-file+ ?flag - NOTE_WRITE +modify-file+ ?flag - NOTE_EXTEND +modify-file+ ?flag - NOTE_ATTRIB +modify-file+ ?flag - NOTE_RENAME +rename-file+ ?flag - NOTE_REVOKE +remove-file+ ?flag - drop - ] { } make prune ; - -:: kevent-vnode-task ( mx kevent fd -- ) - "" - kevent kevent-fflags parse-action - fd mx monitors>> at queue-change ; - : handle-kevent ( mx kevent -- ) - [ ] [ kevent-ident ] [ kevent-filter ] tri { - { [ dup EVFILT_READ = ] [ drop kevent-read-task ] } - { [ dup EVFILT_WRITE = ] [ drop kevent-write-task ] } - { [ dup EVFILT_PROC = ] [ drop kevent-proc-task ] } - { [ dup EVFILT_VNODE = ] [ drop kevent-vnode-task ] } - } cond ; + [ kevent-ident swap ] [ kevent-filter ] bi { + { EVFILT_READ [ input-available ] } + { EVFILT_WRITE [ output-available ] } + } case ; : handle-kevents ( mx n -- ) - [ over events>> kevent-nth handle-kevent ] with each ; + [ dup events>> ] dip head-slice [ handle-kevent ] with each ; M: kqueue-mx wait-for-events ( us mx -- ) swap dup [ make-timespec ] when dupd wait-kevent handle-kevents ; - -! Procs -: make-proc-kevent ( pid -- kevent ) - "kevent" - tuck set-kevent-ident - EV_ADD over set-kevent-flags - EVFILT_PROC over set-kevent-filter - NOTE_EXIT over set-kevent-fflags ; - -: register-pid-task ( pid mx -- ) - swap make-proc-kevent swap register-kevent ; - -! VNodes -TUPLE: vnode-monitor < monitor fd ; - -: vnode-fflags ( -- n ) - { - NOTE_DELETE - NOTE_WRITE - NOTE_EXTEND - NOTE_ATTRIB - NOTE_LINK - NOTE_RENAME - NOTE_REVOKE - } flags ; - -: make-vnode-kevent ( fd flags -- kevent ) - "kevent" - tuck set-kevent-flags - tuck set-kevent-ident - EVFILT_VNODE over set-kevent-filter - vnode-fflags over set-kevent-fflags ; - -: register-monitor ( monitor mx -- ) - >r dup fd>> r> - [ >r EV_ADD EV_CLEAR bitor make-vnode-kevent r> register-kevent drop ] - [ monitors>> set-at ] 3bi ; - -: unregister-monitor ( monitor mx -- ) - >r fd>> r> - [ monitors>> delete-at ] - [ >r EV_DELETE make-vnode-kevent r> register-kevent ] 2bi ; - -: ( path mailbox -- monitor ) - >r [ O_RDONLY 0 open dup io-error ] keep r> - vnode-monitor new-monitor swap >>fd - [ dup kqueue-mx get register-monitor ] [ ] [ fd>> close ] cleanup ; - -M: vnode-monitor dispose - [ kqueue-mx get unregister-monitor ] [ fd>> close ] bi ; From 080cc92239e8f175487d06900720f7181ab4d6a9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Dec 2008 17:45:41 -0600 Subject: [PATCH 064/150] Add a new deploy test for a new problem, clean up deploy tests, uncomment bunny test now that bunny is back in extra --- basis/tools/deploy/deploy-tests.factor | 29 ++++++++++--------------- basis/tools/deploy/test/8/8.factor | 11 ++++++++++ basis/tools/deploy/test/8/deploy.factor | 15 +++++++++++++ 3 files changed, 37 insertions(+), 18 deletions(-) create mode 100644 basis/tools/deploy/test/8/8.factor create mode 100644 basis/tools/deploy/test/8/deploy.factor diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index e3fd9b9a7c..9cc48972fa 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -14,34 +14,22 @@ urls math.parser ; : small-enough? ( n -- ? ) [ "test.image" temp-file file-info size>> ] [ cell 4 / * ] bi* <= ; -[ ] [ "hello-world" shake-and-bake ] unit-test +[ t ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test -[ t ] [ 500000 small-enough? ] unit-test +[ t ] [ "sudoku" shake-and-bake 800000 small-enough? ] unit-test -[ ] [ "sudoku" shake-and-bake ] unit-test - -[ t ] [ 800000 small-enough? ] unit-test - -[ ] [ "hello-ui" shake-and-bake ] unit-test - -[ t ] [ 1300000 small-enough? ] unit-test +[ t ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test [ "staging.math-compiler-threads-ui-strip.image" ] [ "hello-ui" deploy-config [ bootstrap-profile staging-image-name file-name ] bind ] unit-test -[ ] [ "maze" shake-and-bake ] unit-test +[ t ] [ "maze" shake-and-bake 1200000 small-enough? ] unit-test -[ t ] [ 1200000 small-enough? ] unit-test +[ t ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test -[ ] [ "tetris" shake-and-bake ] unit-test - -[ t ] [ 1500000 small-enough? ] unit-test - -! [ ] [ "bunny" shake-and-bake ] unit-test - -! [ t ] [ 2500000 small-enough? ] unit-test +[ t ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test : run-temp-image ( -- ) vm @@ -110,3 +98,8 @@ M: quit-responder call-responder* "tools.deploy.test.7" shake-and-bake run-temp-image ] unit-test + +[ ] [ + "tools.deploy.test.8" shake-and-bake + run-temp-image +] unit-test diff --git a/basis/tools/deploy/test/8/8.factor b/basis/tools/deploy/test/8/8.factor new file mode 100644 index 0000000000..c495928bf2 --- /dev/null +++ b/basis/tools/deploy/test/8/8.factor @@ -0,0 +1,11 @@ +USING: kernel ; +IN: tools.deploy.test.8 + +: literal-merge-test-1 ( -- x ) H{ { "lil" "wayne" } } ; +: literal-merge-test-2 ( -- x ) H{ { "lil" "wayne" } } ; + +: literal-merge-test ( -- ) + literal-merge-test-1 + literal-merge-test-2 eq? t assert= ; + +MAIN: literal-merge-test diff --git a/basis/tools/deploy/test/8/deploy.factor b/basis/tools/deploy/test/8/deploy.factor new file mode 100644 index 0000000000..3bea1edfc7 --- /dev/null +++ b/basis/tools/deploy/test/8/deploy.factor @@ -0,0 +1,15 @@ +USING: tools.deploy.config ; +H{ + { deploy-name "tools.deploy.test.8" } + { deploy-c-types? f } + { deploy-word-props? f } + { deploy-ui? f } + { deploy-reflection 1 } + { deploy-compiler? f } + { deploy-unicode? f } + { deploy-io 1 } + { deploy-word-defs? f } + { deploy-threads? f } + { "stop-after-last-window?" t } + { deploy-math? f } +} From 45e428f186f1289549e61e74943bad701ed4de05 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 6 Dec 2008 18:25:35 -0600 Subject: [PATCH 065/150] fix file-systems on mac --- basis/io/unix/files/macosx/macosx.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/io/unix/files/macosx/macosx.factor b/basis/io/unix/files/macosx/macosx.factor index 5b128143d9..322358ba14 100644 --- a/basis/io/unix/files/macosx/macosx.factor +++ b/basis/io/unix/files/macosx/macosx.factor @@ -13,7 +13,8 @@ M: macosx file-systems ( -- array ) f dup 0 getmntinfo64 dup io-error [ *void* ] dip "statfs64" heap-size [ * memory>byte-array ] keep group - [ [ new-file-system-info ] dip statfs>file-system-info ] map ; + [ statfs64-f_mntonname utf8 alien>string file-system-info ] map ; + ! [ [ new-file-system-info ] dip statfs>file-system-info ] map ; M: macosx new-file-system-info macosx-file-system-info new ; From 0290be6e93e64b3b4fb5d77dd15b86f244427e1c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Dec 2008 18:37:28 -0600 Subject: [PATCH 066/150] Exploit the fast-path for allocation of array with initial element 0 by changing new-sequence on arrays, the vector constructor, and resize-array, called when growing vectors, to fill arrays with 0 instead of f. user code never observes the initial value in these situations anyway. small speedup on bootstrap --- core/arrays/arrays.factor | 4 ++-- core/assocs/assocs.factor | 2 +- core/namespaces/namespaces.factor | 6 +++--- core/vectors/vectors.factor | 2 +- vm/bignum.c | 2 +- vm/types.c | 28 +++++++++------------------- vm/types.h | 6 +++--- 7 files changed, 20 insertions(+), 30 deletions(-) diff --git a/core/arrays/arrays.factor b/core/arrays/arrays.factor index 157ac013e3..4a998a1ebb 100644 --- a/core/arrays/arrays.factor +++ b/core/arrays/arrays.factor @@ -12,9 +12,9 @@ M: array resize resize-array ; : >array ( seq -- array ) { } clone-like ; -M: object new-sequence drop f ; +M: object new-sequence drop 0 ; -M: f new-sequence drop dup zero? [ drop f ] [ f ] if ; +M: f new-sequence drop dup zero? [ drop f ] [ 0 ] if ; M: array equal? over array? [ sequence= ] [ 2drop f ] if ; diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index a0d16084b1..76745cc015 100644 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -90,7 +90,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) ] if ; inline recursive : assoc-stack ( key seq -- value ) - dup length 1- swap (assoc-stack) ; + dup length 1- swap (assoc-stack) ; flushable : assoc-subset? ( assoc1 assoc2 -- ? ) [ swapd at* [ = ] [ 2drop f ] if ] curry assoc-all? ; diff --git a/core/namespaces/namespaces.factor b/core/namespaces/namespaces.factor index 427c294759..36559095cb 100644 --- a/core/namespaces/namespaces.factor +++ b/core/namespaces/namespaces.factor @@ -12,12 +12,12 @@ IN: namespaces PRIVATE> -: namespace ( -- namespace ) namestack* peek ; +: namespace ( -- namespace ) namestack* peek ; inline : namestack ( -- namestack ) namestack* clone ; : set-namestack ( namestack -- ) >vector 0 setenv ; : global ( -- g ) 21 getenv { hashtable } declare ; inline : init-namespaces ( -- ) global 1array set-namestack ; -: get ( variable -- value ) namestack* assoc-stack ; flushable +: get ( variable -- value ) namestack* assoc-stack ; inline : set ( value variable -- ) namespace set-at ; : on ( variable -- ) t swap set ; inline : off ( variable -- ) f swap set ; inline @@ -28,7 +28,7 @@ PRIVATE> : inc ( variable -- ) 1 swap +@ ; inline : dec ( variable -- ) -1 swap +@ ; inline : bind ( ns quot -- ) swap >n call ndrop ; inline -: counter ( variable -- n ) global [ dup inc get ] bind ; +: counter ( variable -- n ) global [ 0 or 1+ dup ] change-at ; : make-assoc ( quot exemplar -- hash ) 20 swap new-assoc [ >n call ndrop ] keep ; inline diff --git a/core/vectors/vectors.factor b/core/vectors/vectors.factor index b4cade44db..a6bfef71d0 100644 --- a/core/vectors/vectors.factor +++ b/core/vectors/vectors.factor @@ -8,7 +8,7 @@ TUPLE: vector { underlying array } { length array-capacity } ; -: ( n -- vector ) f 0 vector boa ; inline +: ( n -- vector ) 0 0 vector boa ; inline : >vector ( seq -- vector ) V{ } clone-like ; diff --git a/vm/bignum.c b/vm/bignum.c index 72616afbc5..1f4bc3ce76 100644 --- a/vm/bignum.c +++ b/vm/bignum.c @@ -1396,7 +1396,7 @@ allot_bignum_zeroed(bignum_length_type length, int negative_p) } #define BIGNUM_REDUCE_LENGTH(source, length) \ - source = reallot_array(source,length + 1,0) + source = reallot_array(source,length + 1) /* allocates memory */ bignum_type diff --git a/vm/types.c b/vm/types.c index a614011e7e..1afbcd3a40 100755 --- a/vm/types.c +++ b/vm/types.c @@ -157,27 +157,18 @@ CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4) return tag_object(a); } -F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill) +F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity) { - int i; - F_ARRAY* new_array; - CELL to_copy = array_capacity(array); if(capacity < to_copy) to_copy = capacity; REGISTER_UNTAGGED(array); - REGISTER_ROOT(fill); - - new_array = allot_array_internal(untag_header(array->header),capacity); - - UNREGISTER_ROOT(fill); + F_ARRAY* new_array = allot_array_internal(untag_header(array->header),capacity); UNREGISTER_UNTAGGED(array); memcpy(new_array + 1,array + 1,to_copy * CELLS); - - for(i = to_copy; i < capacity; i++) - put(AREF(new_array,i),fill); + memset((char *)AREF(new_array,to_copy),'\0',(capacity - to_copy) * CELLS); return new_array; } @@ -186,7 +177,7 @@ void primitive_resize_array(void) { F_ARRAY* array = untag_array(dpop()); CELL capacity = unbox_array_size(); - dpush(tag_object(reallot_array(array,capacity,F))); + dpush(tag_object(reallot_array(array,capacity))); } F_ARRAY *growable_array_add(F_ARRAY *result, CELL elt, CELL *result_count) @@ -195,8 +186,7 @@ F_ARRAY *growable_array_add(F_ARRAY *result, CELL elt, CELL *result_count) if(*result_count == array_capacity(result)) { - result = reallot_array(result, - *result_count * 2,F); + result = reallot_array(result,*result_count * 2); } UNREGISTER_ROOT(elt); @@ -214,7 +204,7 @@ F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_coun CELL new_size = *result_count + elts_size; if(new_size >= array_capacity(result)) - result = reallot_array(result,new_size * 2,F); + result = reallot_array(result,new_size * 2); UNREGISTER_UNTAGGED(elts); @@ -433,7 +423,7 @@ void primitive_string(void) dpush(tag_object(allot_string(length,initial))); } -F_STRING* reallot_string(F_STRING* string, CELL capacity, CELL fill) +F_STRING* reallot_string(F_STRING* string, CELL capacity) { CELL to_copy = string_capacity(string); if(capacity < to_copy) @@ -462,7 +452,7 @@ F_STRING* reallot_string(F_STRING* string, CELL capacity, CELL fill) REGISTER_UNTAGGED(string); REGISTER_UNTAGGED(new_string); - fill_string(new_string,to_copy,capacity,fill); + fill_string(new_string,to_copy,capacity,'\0'); UNREGISTER_UNTAGGED(new_string); UNREGISTER_UNTAGGED(string); @@ -473,7 +463,7 @@ void primitive_resize_string(void) { F_STRING* string = untag_string(dpop()); CELL capacity = unbox_array_size(); - dpush(tag_object(reallot_string(string,capacity,0))); + dpush(tag_object(reallot_string(string,capacity))); } /* Some ugly macros to prevent a 2x code duplication */ diff --git a/vm/types.h b/vm/types.h index 242939c502..ba8d9689fe 100755 --- a/vm/types.h +++ b/vm/types.h @@ -118,7 +118,7 @@ void primitive_tuple_layout(void); void primitive_byte_array(void); void primitive_clone(void); -F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill); +F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity); F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity); void primitive_resize_array(void); void primitive_resize_byte_array(void); @@ -126,7 +126,7 @@ void primitive_resize_byte_array(void); F_STRING* allot_string_internal(CELL capacity); F_STRING* allot_string(CELL capacity, CELL fill); void primitive_string(void); -F_STRING *reallot_string(F_STRING *string, CELL capacity, CELL fill); +F_STRING *reallot_string(F_STRING *string, CELL capacity); void primitive_resize_string(void); F_STRING *memory_to_char_string(const char *string, CELL length); @@ -177,7 +177,7 @@ F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_coun result = tag_object(growable_array_append(untag_object(result),elts,&result##_count)) #define GROWABLE_ARRAY_TRIM(result) \ - result = tag_object(reallot_array(untag_object(result),result##_count,F)) + result = tag_object(reallot_array(untag_object(result),result##_count)) /* Macros to simulate a byte vector in C */ #define GROWABLE_BYTE_ARRAY(result) \ From 294b84b659580868c1c0f8328be6ae43940b985b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 6 Dec 2008 18:41:13 -0600 Subject: [PATCH 067/150] remove extra short definition --- extra/project-euler/117/117.factor | 3 --- 1 file changed, 3 deletions(-) diff --git a/extra/project-euler/117/117.factor b/extra/project-euler/117/117.factor index 7174066227..b90a98173e 100644 --- a/extra/project-euler/117/117.factor +++ b/extra/project-euler/117/117.factor @@ -27,9 +27,6 @@ IN: project-euler.117 Date: Sat, 6 Dec 2008 18:42:41 -0600 Subject: [PATCH 068/150] swap ... 3append -> surround in core --- core/classes/intersection/intersection.factor | 2 +- core/parser/parser.factor | 6 +++--- core/slots/slots.factor | 2 +- core/words/words.factor | 2 +- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/core/classes/intersection/intersection.factor b/core/classes/intersection/intersection.factor index fffb172204..43018f6358 100644 --- a/core/classes/intersection/intersection.factor +++ b/core/classes/intersection/intersection.factor @@ -12,7 +12,7 @@ PREDICATE: intersection-class < class [ drop t ] ] [ unclip "predicate" word-prop swap [ - "predicate" word-prop [ dup ] swap [ not ] 3append + "predicate" word-prop [ dup ] [ not ] surround [ drop f ] ] { } map>assoc alist>quot ] if-empty ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 3f3af935b6..4586cfe34e 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -71,7 +71,7 @@ TUPLE: no-current-vocab ; : word-restarts ( name possibilities -- restarts ) natural-sort - [ [ "Use the " swap vocabulary>> " vocabulary" 3append ] keep ] { } map>assoc + [ [ vocabulary>> "Use the " " vocabulary" surround ] keep ] { } map>assoc swap "Defer word in current vocabulary" swap 2array suffix ; @@ -89,7 +89,7 @@ SYMBOL: auto-use? dup vocabulary>> [ (use+) ] [ amended-use get dup [ push ] [ 2drop ] if ] - [ "Added ``" swap "'' vocabulary to search path" 3append note. ] + [ "Added ``" "'' vocabulary to search path" surround note. ] tri ] [ create-in ] if ; @@ -292,7 +292,7 @@ print-use-hook global [ [ ] or ] change-at ] with-compilation-unit ; : parse-file-restarts ( file -- restarts ) - "Load " swap " again" 3append t 2array 1array ; + "Load " " again" surround t 2array 1array ; : parse-file ( file -- quot ) [ diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 35aa49d053..187db02c5c 100644 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -50,7 +50,7 @@ PREDICATE: writer < word "writer" word-prop ; define-typecheck ; : writer-word ( name -- word ) - "(>>" swap ")" 3append (( value object -- )) create-accessor + "(>>" ")" surround (( value object -- )) create-accessor dup t "writer" set-word-prop ; ERROR: bad-slot-value value class ; diff --git a/core/words/words.factor b/core/words/words.factor index b36f8be677..8c144b03a2 100644 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -239,7 +239,7 @@ ERROR: bad-create name vocab ; dup [ 2nip ] [ drop dup reveal ] if ; : constructor-word ( name vocab -- word ) - [ "<" swap ">" 3append ] dip create ; + [ "<" ">" surround ] dip create ; PREDICATE: parsing-word < word "parsing" word-prop ; From c75777b7a208d0ded033e15838ae2e9d42252cc4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 6 Dec 2008 18:58:05 -0600 Subject: [PATCH 069/150] swap ... 3append -> surround in extra --- extra/combinators/lib/lib-tests.factor | 2 +- extra/html/parser/utils/utils.factor | 4 ++-- extra/multi-methods/multi-methods.factor | 2 +- extra/parser-combinators/simple/simple-docs.factor | 4 ++-- extra/raptor/raptor.factor | 4 ++-- extra/webapps/wiki/wiki.factor | 2 +- 6 files changed, 9 insertions(+), 9 deletions(-) diff --git a/extra/combinators/lib/lib-tests.factor b/extra/combinators/lib/lib-tests.factor index 838bb08b92..9489798b9b 100755 --- a/extra/combinators/lib/lib-tests.factor +++ b/extra/combinators/lib/lib-tests.factor @@ -16,7 +16,7 @@ IN: combinators.lib.tests [ { "foo" "xbarx" } ] [ - { "oof" "bar" } { [ reverse ] [ "x" swap "x" 3append ] } parallel-call + { "oof" "bar" } { [ reverse ] [ "x" dup surround ] } parallel-call ] unit-test { 1 1 } [ diff --git a/extra/html/parser/utils/utils.factor b/extra/html/parser/utils/utils.factor index 976a5ba91f..2f414d2aa5 100644 --- a/extra/html/parser/utils/utils.factor +++ b/extra/html/parser/utils/utils.factor @@ -16,10 +16,10 @@ IN: html.parser.utils [ ?head drop ] [ ?tail drop ] bi ; : single-quote ( str -- newstr ) - "'" swap "'" 3append ; + "'" dup surround ; : double-quote ( str -- newstr ) - "\"" swap "\"" 3append ; + "\"" dup surround ; : quote ( str -- newstr ) CHAR: ' over member? diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index 682abf3a5d..14062b15db 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -102,7 +102,7 @@ SYMBOL: total { 0 [ [ dup ] ] } { 1 [ [ over ] ] } { 2 [ [ pick ] ] } - [ 1- picker [ >r ] swap [ r> swap ] 3append ] + [ 1- picker [ >r ] [ r> swap ] surround ] } case ; : (multi-predicate) ( class picker -- quot ) diff --git a/extra/parser-combinators/simple/simple-docs.factor b/extra/parser-combinators/simple/simple-docs.factor index fdf32bddb1..be6c01aab8 100755 --- a/extra/parser-combinators/simple/simple-docs.factor +++ b/extra/parser-combinators/simple/simple-docs.factor @@ -41,7 +41,7 @@ HELP: 'bold' "commonly used in markup languages to indicate bold " "faced text." } { $example "USING: parser-combinators parser-combinators.simple prettyprint ;" "\"*foo*\" 'bold' parse-1 ." "\"foo\"" } -{ $example "USING: kernel parser-combinators parser-combinators.simple prettyprint sequences ;" "\"*foo*\" 'bold' [ \"\" swap \"\" 3append ] <@ parse-1 ." "\"foo\"" } ; +{ $example "USING: kernel parser-combinators parser-combinators.simple prettyprint sequences ;" "\"*foo*\" 'bold' [ \"\" \"\" surround ] <@ parse-1 ." "\"foo\"" } ; HELP: 'italic' { $values @@ -53,7 +53,7 @@ HELP: 'italic' "faced text." } { $examples { $example "USING: parser-combinators parser-combinators.simple prettyprint ;" "\"_foo_\" 'italic' parse-1 ." "\"foo\"" } -{ $example "USING: kernel parser-combinators parser-combinators.simple prettyprint sequences ;" "\"_foo_\" 'italic' [ \"\" swap \"\" 3append ] <@ parse-1 ." "\"foo\"" } } ; +{ $example "USING: kernel parser-combinators parser-combinators.simple prettyprint sequences ;" "\"_foo_\" 'italic' [ \"\" \"\" surround ] <@ parse-1 ." "\"foo\"" } } ; HELP: comma-list { $values { "element" "a parser object" } { "parser" "a parser object" } } diff --git a/extra/raptor/raptor.factor b/extra/raptor/raptor.factor index 933275e5bf..c0605fe837 100755 --- a/extra/raptor/raptor.factor +++ b/extra/raptor/raptor.factor @@ -32,8 +32,8 @@ SYMBOL: networking-hook ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: start-service ( name -- ) "/etc/init.d/" swap " start" 3append system drop ; -: stop-service ( name -- ) "/etc/init.d/" swap " stop" 3append system drop ; +: start-service ( name -- ) "/etc/init.d/" " start" surround system drop ; +: stop-service ( name -- ) "/etc/init.d/" " stop" surround system drop ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index b78dc25d79..f2c0600ed5 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -230,7 +230,7 @@ M: revision feed-entry-url id>> revision-url ; [ list-revisions ] >>entries ; : rollback-description ( description -- description' ) - [ "Rollback of '" swap "'" 3append ] [ "Rollback" ] if* ; + [ "Rollback of '" "'" surround ] [ "Rollback" ] if* ; : ( -- action ) From 14fb58f448c1f32c5e09b4407b9813e599cfe1be Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 6 Dec 2008 18:58:45 -0600 Subject: [PATCH 070/150] swap ... 3append -> surround in basis --- basis/bootstrap/image/image.factor | 2 +- basis/db/sqlite/sqlite.factor | 2 +- basis/html/elements/elements.factor | 6 +++--- basis/io/windows/launcher/launcher.factor | 2 +- basis/prettyprint/backend/backend.factor | 2 +- basis/smtp/smtp.factor | 6 ++++-- basis/tools/vocabs/browser/browser.factor | 2 +- basis/ui/freetype/freetype.factor | 2 +- basis/ui/tools/deploy/deploy.factor | 2 +- 9 files changed, 14 insertions(+), 12 deletions(-) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 380c9b2348..c7d87776a1 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -23,7 +23,7 @@ IN: bootstrap.image os name>> cpu name>> arch ; : boot-image-name ( arch -- string ) - "boot." swap ".image" 3append ; + "boot." ".image" surround ; : my-boot-image-name ( -- string ) my-arch boot-image-name ; diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index 4e96fb5a4d..32c5ca0075 100644 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -164,7 +164,7 @@ M: sqlite-db ( tuple -- statement ) M: sqlite-db bind# ( spec obj -- ) [ - [ column-name>> ":" swap next-sql-counter 3append dup 0% ] + [ column-name>> ":" next-sql-counter surround dup 0% ] [ type>> ] bi ] dip 1, ; diff --git a/basis/html/elements/elements.factor b/basis/html/elements/elements.factor index fa92f18d34..2149bf7bf6 100644 --- a/basis/html/elements/elements.factor +++ b/basis/html/elements/elements.factor @@ -26,7 +26,7 @@ SYMBOL: html #! dynamically creating words. [ elements-vocab create ] 2dip define-declared ; -: ( str -- ) "<" swap ">" 3append ; +: ( str -- ) "<" ">" surround ; : def-for-html-word- ( name -- ) #! Return the name and code for the patterned @@ -49,14 +49,14 @@ SYMBOL: html #! word. foo> [ ">" write-html ] (( -- )) html-word ; -: ( str -- ) "" 3append ; +: ( str -- ) "" surround ; : def-for-html-word- ( name -- ) #! Return the name and code for the patterned #! word. dup '[ _ write-html ] (( -- )) html-word ; -: ( str -- ) "<" swap "/>" 3append ; +: ( str -- ) "<" "/>" surround ; : def-for-html-word- ( name -- ) #! Return the name and code for the patterned diff --git a/basis/io/windows/launcher/launcher.factor b/basis/io/windows/launcher/launcher.factor index 212b405a54..fd31ca999f 100644 --- a/basis/io/windows/launcher/launcher.factor +++ b/basis/io/windows/launcher/launcher.factor @@ -56,7 +56,7 @@ TUPLE: CreateProcess-args : escape-argument ( str -- newstr ) CHAR: \s over member? [ - "\"" swap fix-trailing-backslashes "\"" 3append + fix-trailing-backslashes "\"" dup surround ] when ; : join-arguments ( args -- cmd-line ) diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index 7a5b16a3c2..76c3918f63 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -10,7 +10,7 @@ IN: prettyprint.backend GENERIC: pprint* ( obj -- ) -M: effect pprint* effect>string "(" swap ")" 3append text ; +M: effect pprint* effect>string "(" ")" surround text ; : ?effect-height ( word -- n ) stack-effect [ effect-height ] [ 0 ] if* ; diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor index 7f14945633..f689ad0858 100644 --- a/basis/smtp/smtp.factor +++ b/basis/smtp/smtp.factor @@ -72,10 +72,12 @@ ERROR: bad-email-address email ; [ bad-email-address ] unless ; : mail-from ( fromaddr -- ) - "MAIL FROM:<" swap validate-address ">" 3append command ; + validate-address + "MAIL FROM:<" ">" surround command ; : rcpt-to ( to -- ) - "RCPT TO:<" swap validate-address ">" 3append command ; + validate-address + "RCPT TO:<" ">" surround command ; : data ( -- ) "DATA" command ; diff --git a/basis/tools/vocabs/browser/browser.factor b/basis/tools/vocabs/browser/browser.factor index 4cd5653ab4..e9e8d27870 100644 --- a/basis/tools/vocabs/browser/browser.factor +++ b/basis/tools/vocabs/browser/browser.factor @@ -289,7 +289,7 @@ M: vocab-spec article-parent drop "vocab-index" ; M: vocab-tag >link ; M: vocab-tag article-title - name>> "Vocabularies tagged ``" swap "''" 3append ; + name>> "Vocabularies tagged ``" "''" surround ; M: vocab-tag article-name name>> ; diff --git a/basis/ui/freetype/freetype.factor b/basis/ui/freetype/freetype.factor index b0d152fc88..6c0eaaa9ac 100644 --- a/basis/ui/freetype/freetype.factor +++ b/basis/ui/freetype/freetype.factor @@ -61,7 +61,7 @@ M: freetype-renderer free-fonts ( world -- ) } at ; : ttf-path ( name -- string ) - "resource:fonts/" swap ".ttf" 3append ; + "resource:fonts/" ".ttf" surround ; : (open-face) ( path length -- face ) #! We use FT_New_Memory_Face, not FT_New_Face, since diff --git a/basis/ui/tools/deploy/deploy.factor b/basis/ui/tools/deploy/deploy.factor index 127269b325..f023b0959a 100644 --- a/basis/ui/tools/deploy/deploy.factor +++ b/basis/ui/tools/deploy/deploy.factor @@ -119,5 +119,5 @@ deploy-gadget "toolbar" f { : deploy-tool ( vocab -- ) vocab-name [ 10 ] - [ "Deploying \"" swap "\"" 3append ] bi + [ "Deploying \"" "\"" surround ] bi open-window ; From ce6ed41cbe1ac97e3a7f75b88f4aa71617b8e1c0 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sat, 6 Dec 2008 23:27:32 -0200 Subject: [PATCH 071/150] irc.messages: Fix parsing of MODE messages with the mode on the trailing part of the message --- extra/irc/messages/messages.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index bea9bf37b1..8054dc8075 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -90,11 +90,11 @@ M: end-of-names >>command-parameters ( names-reply params -- names-reply ) first2 [ >>who ] [ >>channel ] bi* ; M: mode >>command-parameters ( mode params -- mode ) - dup length 3 = [ - first3 [ >>name ] [ >>mode ] [ >>parameter ] tri* - ] [ - first2 [ >>name ] [ >>mode ] bi* - ] if ; + dup length { + { 3 [ first3 [ >>name ] [ >>mode ] [ >>parameter ] tri* ] } + { 2 [ first2 [ >>name ] [ >>mode ] bi* ] } + [ drop first >>name dup trailing>> >>mode ] + } case ; PRIVATE> @@ -135,12 +135,12 @@ M: irc-message irc-message>server-line ( irc-message -- string ) : copy-message-in ( command irc-message -- command ) { - [ parameters>> [ >>parameters ] [ >>command-parameters ] bi ] [ line>> >>line ] [ prefix>> >>prefix ] [ command>> >>command ] [ trailing>> >>trailing ] [ timestamp>> >>timestamp ] + [ parameters>> [ >>parameters ] [ >>command-parameters ] bi ] } cleave ; PRIVATE> From 34fe5769196cd8ef82ab4643e588c4588bff6de8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 6 Dec 2008 22:58:19 -0600 Subject: [PATCH 072/150] rename hardware-info to system-info --- extra/{hardware-info => system-info}/authors.txt | 0 .../backend/authors.txt | 0 .../backend/backend.factor | 4 +++- .../linux/authors.txt | 0 .../linux/linux.factor | 4 +++- .../{hardware-info => system-info}/linux/tags.txt | 0 .../macosx/authors.txt | 0 .../macosx/macosx.factor | 10 +++++----- .../{hardware-info => system-info}/macosx/tags.txt | 0 extra/{hardware-info => system-info}/summary.txt | 0 .../system-info.factor} | 14 ++++++++------ .../windows/authors.txt | 0 .../windows/ce/authors.txt | 0 .../windows/ce/ce.factor | 8 +++++--- .../windows/ce/tags.txt | 0 .../windows/nt/authors.txt | 0 .../windows/nt/nt.factor | 8 +++++--- .../windows/nt/tags.txt | 0 .../windows/tags.txt | 0 .../windows/windows.factor | 10 ++++++---- 20 files changed, 35 insertions(+), 23 deletions(-) rename extra/{hardware-info => system-info}/authors.txt (100%) rename extra/{hardware-info => system-info}/backend/authors.txt (100%) rename extra/{hardware-info => system-info}/backend/backend.factor (75%) rename extra/{hardware-info => system-info}/linux/authors.txt (100%) rename extra/{hardware-info => system-info}/linux/linux.factor (84%) rename extra/{hardware-info => system-info}/linux/tags.txt (100%) rename extra/{hardware-info => system-info}/macosx/authors.txt (100%) rename extra/{hardware-info => system-info}/macosx/macosx.factor (90%) rename extra/{hardware-info => system-info}/macosx/tags.txt (100%) rename extra/{hardware-info => system-info}/summary.txt (100%) rename extra/{hardware-info/hardware-info.factor => system-info/system-info.factor} (60%) rename extra/{hardware-info => system-info}/windows/authors.txt (100%) rename extra/{hardware-info => system-info}/windows/ce/authors.txt (100%) rename extra/{hardware-info => system-info}/windows/ce/ce.factor (76%) rename extra/{hardware-info => system-info}/windows/ce/tags.txt (100%) rename extra/{hardware-info => system-info}/windows/nt/authors.txt (100%) rename extra/{hardware-info => system-info}/windows/nt/nt.factor (85%) rename extra/{hardware-info => system-info}/windows/nt/tags.txt (100%) rename extra/{hardware-info => system-info}/windows/tags.txt (100%) rename extra/{hardware-info => system-info}/windows/windows.factor (87%) diff --git a/extra/hardware-info/authors.txt b/extra/system-info/authors.txt similarity index 100% rename from extra/hardware-info/authors.txt rename to extra/system-info/authors.txt diff --git a/extra/hardware-info/backend/authors.txt b/extra/system-info/backend/authors.txt similarity index 100% rename from extra/hardware-info/backend/authors.txt rename to extra/system-info/backend/authors.txt diff --git a/extra/hardware-info/backend/backend.factor b/extra/system-info/backend/backend.factor similarity index 75% rename from extra/hardware-info/backend/backend.factor rename to extra/system-info/backend/backend.factor index 283fea6fcc..6e6715f619 100644 --- a/extra/hardware-info/backend/backend.factor +++ b/extra/system-info/backend/backend.factor @@ -1,5 +1,7 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: system ; -IN: hardware-info.backend +IN: system-info.backend HOOK: cpus os ( -- n ) HOOK: cpu-mhz os ( -- n ) diff --git a/extra/hardware-info/linux/authors.txt b/extra/system-info/linux/authors.txt similarity index 100% rename from extra/hardware-info/linux/authors.txt rename to extra/system-info/linux/authors.txt diff --git a/extra/hardware-info/linux/linux.factor b/extra/system-info/linux/linux.factor similarity index 84% rename from extra/hardware-info/linux/linux.factor rename to extra/system-info/linux/linux.factor index ba0cb0c170..d7f53fb9fb 100644 --- a/extra/hardware-info/linux/linux.factor +++ b/extra/system-info/linux/linux.factor @@ -1,6 +1,8 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: unix alien alien.c-types kernel math sequences strings io.unix.backend splitting ; -IN: hardware-info.linux +IN: system-info.linux : (uname) ( buf -- int ) "int" f "uname" { "char*" } alien-invoke ; diff --git a/extra/hardware-info/linux/tags.txt b/extra/system-info/linux/tags.txt similarity index 100% rename from extra/hardware-info/linux/tags.txt rename to extra/system-info/linux/tags.txt diff --git a/extra/hardware-info/macosx/authors.txt b/extra/system-info/macosx/authors.txt similarity index 100% rename from extra/hardware-info/macosx/authors.txt rename to extra/system-info/macosx/authors.txt diff --git a/extra/hardware-info/macosx/macosx.factor b/extra/system-info/macosx/macosx.factor similarity index 90% rename from extra/hardware-info/macosx/macosx.factor rename to extra/system-info/macosx/macosx.factor index e3c604f2fd..a06c01b950 100644 --- a/extra/hardware-info/macosx/macosx.factor +++ b/extra/system-info/macosx/macosx.factor @@ -1,8 +1,9 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings alien.syntax byte-arrays kernel namespaces sequences unix -hardware-info.backend system io.unix.backend io.encodings.ascii -; -IN: hardware-info.macosx +system-info.backend system io.unix.backend io.encodings.utf8 ; +IN: system-info.macosx ! See /usr/include/sys/sysctl.h for constants @@ -20,7 +21,7 @@ FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, voi [ ] [ ] bi (sysctl-query) ; : sysctl-query-string ( seq -- n ) - 4096 sysctl-query ascii malloc-string ; + 4096 sysctl-query utf8 alien>string ; : sysctl-query-uint ( seq -- n ) 4 sysctl-query *uint ; @@ -53,4 +54,3 @@ M: macosx cpu-mhz ( -- n ) { 6 15 } sysctl-query-uint ; : tb-frequency ( -- n ) { 6 23 } sysctl-query-uint ; : mem-size ( -- n ) { 6 24 } sysctl-query-ulonglong ; : available-cpus ( -- n ) { 6 25 } sysctl-query-uint ; - diff --git a/extra/hardware-info/macosx/tags.txt b/extra/system-info/macosx/tags.txt similarity index 100% rename from extra/hardware-info/macosx/tags.txt rename to extra/system-info/macosx/tags.txt diff --git a/extra/hardware-info/summary.txt b/extra/system-info/summary.txt similarity index 100% rename from extra/hardware-info/summary.txt rename to extra/system-info/summary.txt diff --git a/extra/hardware-info/hardware-info.factor b/extra/system-info/system-info.factor similarity index 60% rename from extra/hardware-info/hardware-info.factor rename to extra/system-info/system-info.factor index cc345c7537..5bf886abd8 100755 --- a/extra/hardware-info/hardware-info.factor +++ b/extra/system-info/system-info.factor @@ -1,6 +1,8 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: alien.syntax kernel math prettyprint io math.parser -combinators vocabs.loader hardware-info.backend system ; -IN: hardware-info +combinators vocabs.loader system-info.backend system ; +IN: system-info : write-unit ( x n str -- ) [ 2^ /f number>string write bl ] [ write ] bi* ; @@ -11,13 +13,13 @@ IN: hardware-info : ghz ( x -- ) 1000000000 /f number>string write bl "GHz" write ; << { - { [ os windows? ] [ "hardware-info.windows" ] } - { [ os linux? ] [ "hardware-info.linux" ] } - { [ os macosx? ] [ "hardware-info.macosx" ] } + { [ os windows? ] [ "system-info.windows" ] } + { [ os linux? ] [ "system-info.linux" ] } + { [ os macosx? ] [ "system-info.macosx" ] } [ f ] } cond [ require ] when* >> -: hardware-report. ( -- ) +: system-report. ( -- ) "CPUs: " write cpus number>string write nl "CPU Speed: " write cpu-mhz ghz nl "Physical RAM: " write physical-mem megs nl ; diff --git a/extra/hardware-info/windows/authors.txt b/extra/system-info/windows/authors.txt similarity index 100% rename from extra/hardware-info/windows/authors.txt rename to extra/system-info/windows/authors.txt diff --git a/extra/hardware-info/windows/ce/authors.txt b/extra/system-info/windows/ce/authors.txt similarity index 100% rename from extra/hardware-info/windows/ce/authors.txt rename to extra/system-info/windows/ce/authors.txt diff --git a/extra/hardware-info/windows/ce/ce.factor b/extra/system-info/windows/ce/ce.factor similarity index 76% rename from extra/hardware-info/windows/ce/ce.factor rename to extra/system-info/windows/ce/ce.factor index 6537661b3e..13c7cb9433 100755 --- a/extra/hardware-info/windows/ce/ce.factor +++ b/extra/system-info/windows/ce/ce.factor @@ -1,6 +1,8 @@ -USING: alien.c-types hardware-info kernel math namespaces -windows windows.kernel32 hardware-info.backend system ; -IN: hardware-info.windows.ce +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types system-info kernel math namespaces +windows windows.kernel32 system-info.backend system ; +IN: system-info.windows.ce : memory-status ( -- MEMORYSTATUS ) "MEMORYSTATUS" diff --git a/extra/hardware-info/windows/ce/tags.txt b/extra/system-info/windows/ce/tags.txt similarity index 100% rename from extra/hardware-info/windows/ce/tags.txt rename to extra/system-info/windows/ce/tags.txt diff --git a/extra/hardware-info/windows/nt/authors.txt b/extra/system-info/windows/nt/authors.txt similarity index 100% rename from extra/hardware-info/windows/nt/authors.txt rename to extra/system-info/windows/nt/authors.txt diff --git a/extra/hardware-info/windows/nt/nt.factor b/extra/system-info/windows/nt/nt.factor similarity index 85% rename from extra/hardware-info/windows/nt/nt.factor rename to extra/system-info/windows/nt/nt.factor index 6274e7974c..7f71e08e83 100755 --- a/extra/hardware-info/windows/nt/nt.factor +++ b/extra/system-info/windows/nt/nt.factor @@ -1,8 +1,10 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings -kernel libc math namespaces hardware-info.backend -hardware-info.windows windows windows.advapi32 +kernel libc math namespaces system-info.backend +system-info.windows windows windows.advapi32 windows.kernel32 system byte-arrays ; -IN: hardware-info.windows.nt +IN: system-info.windows.nt M: winnt cpus ( -- n ) system-info SYSTEM_INFO-dwNumberOfProcessors ; diff --git a/extra/hardware-info/windows/nt/tags.txt b/extra/system-info/windows/nt/tags.txt similarity index 100% rename from extra/hardware-info/windows/nt/tags.txt rename to extra/system-info/windows/nt/tags.txt diff --git a/extra/hardware-info/windows/tags.txt b/extra/system-info/windows/tags.txt similarity index 100% rename from extra/hardware-info/windows/tags.txt rename to extra/system-info/windows/tags.txt diff --git a/extra/hardware-info/windows/windows.factor b/extra/system-info/windows/windows.factor similarity index 87% rename from extra/hardware-info/windows/windows.factor rename to extra/system-info/windows/windows.factor index d3ebe87501..66abb59ee9 100755 --- a/extra/hardware-info/windows/windows.factor +++ b/extra/system-info/windows/windows.factor @@ -1,8 +1,10 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types kernel libc math namespaces windows windows.kernel32 windows.advapi32 -words combinators vocabs.loader hardware-info.backend +words combinators vocabs.loader system-info.backend system alien.strings ; -IN: hardware-info.windows +IN: system-info.windows : system-info ( -- SYSTEM_INFO ) "SYSTEM_INFO" [ GetSystemInfo ] keep ; @@ -65,6 +67,6 @@ IN: hardware-info.windows << { - { [ os wince? ] [ "hardware-info.windows.ce" ] } - { [ os winnt? ] [ "hardware-info.windows.nt" ] } + { [ os wince? ] [ "system-info.windows.ce" ] } + { [ os winnt? ] [ "system-info.windows.nt" ] } } cond require >> From 9b8fdfc1542ba08915f28636b4de5f2ab8120cbf Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 6 Dec 2008 23:01:17 -0600 Subject: [PATCH 073/150] clean up extra crypto a bit --- extra/crypto/barrett/barrett.factor | 2 -- extra/crypto/hmac/hmac.factor | 2 ++ extra/crypto/timing/timing.factor | 2 ++ extra/crypto/xor/xor.factor | 2 +- 4 files changed, 5 insertions(+), 3 deletions(-) diff --git a/extra/crypto/barrett/barrett.factor b/extra/crypto/barrett/barrett.factor index 25e67d01ce..9d5c65aa94 100644 --- a/extra/crypto/barrett/barrett.factor +++ b/extra/crypto/barrett/barrett.factor @@ -8,5 +8,3 @@ IN: crypto.barrett #! size = word size in bits (8, 16, 32, 64, ...) [ [ log2 1+ ] [ / 2 * ] bi* ] [ 2^ rot ^ swap /i ] 2bi ; - - diff --git a/extra/crypto/hmac/hmac.factor b/extra/crypto/hmac/hmac.factor index d98e8a9798..b480c18913 100755 --- a/extra/crypto/hmac/hmac.factor +++ b/extra/crypto/hmac/hmac.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: arrays combinators checksums checksums.md5 checksums.sha1 checksums.md5.private io io.binary io.files io.streams.byte-array kernel math math.vectors memoize sequences diff --git a/extra/crypto/timing/timing.factor b/extra/crypto/timing/timing.factor index 8fdb807c6a..b2a59a1851 100644 --- a/extra/crypto/timing/timing.factor +++ b/extra/crypto/timing/timing.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: kernel math threads system calendar ; IN: crypto.timing diff --git a/extra/crypto/xor/xor.factor b/extra/crypto/xor/xor.factor index 6e3a605f5c..662881f8cc 100644 --- a/extra/crypto/xor/xor.factor +++ b/extra/crypto/xor/xor.factor @@ -8,5 +8,5 @@ IN: crypto.xor ERROR: empty-xor-key ; : xor-crypt ( seq key -- seq' ) - dup empty? [ empty-xor-key ] when + [ empty-xor-key ] when-empty [ dup length ] dip '[ _ mod-nth bitxor ] 2map ; From 3821b417af1ace5fa5006962719a75eac141de5f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 6 Dec 2008 23:04:54 -0600 Subject: [PATCH 074/150] remove finance words from calendar --- basis/calendar/calendar-docs.factor | 42 ----------------------------- basis/calendar/calendar.factor | 7 ----- 2 files changed, 49 deletions(-) diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index 748f9d124c..3d765aeed9 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -99,48 +99,6 @@ HELP: seconds-per-year { $values { "integer" integer } } { $description "Returns the number of seconds in a year averaged over 400 years. Used internally for adding an arbitrary real number of seconds to a timestamp." } ; -HELP: biweekly -{ $values - { "x" number } - { "y" number } -} -{ $description "Divides a number by the number of two week periods in a year." } ; - -HELP: daily-360 -{ $values - { "x" number } - { "y" number } -} -{ $description "Divides a number by the number of days in a 360-day year." } ; - -HELP: daily-365 -{ $values - { "x" number } - { "y" number } -} -{ $description "Divides a number by the number of days in a 365-day year." } ; - -HELP: monthly -{ $values - { "x" number } - { "y" number } -} -{ $description "Divides a number by the number of months in a year." } ; - -HELP: semimonthly -{ $values - { "x" number } - { "y" number } -} -{ $description "Divides a number by the number of half-months in a year. Note that biweekly has two more periods than semimonthly." } ; - -HELP: weekly -{ $values - { "x" number } - { "y" number } -} -{ $description "Divides a number by the number of weeks in a year." } ; - HELP: julian-day-number { $values { "year" integer } { "month" integer } { "day" integer } { "n" integer } } { $description "Calculates the Julian day number from a year, month, and day. The difference between two Julian day numbers is the number of days that have elapsed between the two corresponding dates." } diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index e2564b5a28..793c771b64 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -89,13 +89,6 @@ PRIVATE> : minutes-per-year ( -- ratio ) 5259492/10 ; inline : seconds-per-year ( -- integer ) 31556952 ; inline -: monthly ( x -- y ) 12 / ; inline -: semimonthly ( x -- y ) 24 / ; inline -: biweekly ( x -- y ) 26 / ; inline -: weekly ( x -- y ) 52 / ; inline -: daily-360 ( x -- y ) 360 / ; inline -: daily-365 ( x -- y ) 365 / ; inline - :: julian-day-number ( year month day -- n ) #! Returns a composite date number #! Not valid before year -4800 From e4efe6ec24832848efca2c6e9332cbb0df3992c5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 6 Dec 2008 23:05:02 -0600 Subject: [PATCH 075/150] add finance words to math.finance --- extra/math/finance/finance-docs.factor | 41 ++++++++++++++++++++++++++ extra/math/finance/finance.factor | 11 +++++++ 2 files changed, 52 insertions(+) diff --git a/extra/math/finance/finance-docs.factor b/extra/math/finance/finance-docs.factor index 5024e83bff..97e44d2927 100644 --- a/extra/math/finance/finance-docs.factor +++ b/extra/math/finance/finance-docs.factor @@ -32,3 +32,44 @@ HELP: momentum { $list "MOM[t] = SEQ[t] - SEQ[t-n]" } } ; +HELP: biweekly +{ $values + { "x" number } + { "y" number } +} +{ $description "Divides a number by the number of two week periods in a year." } ; + +HELP: daily-360 +{ $values + { "x" number } + { "y" number } +} +{ $description "Divides a number by the number of days in a 360-day year." } ; + +HELP: daily-365 +{ $values + { "x" number } + { "y" number } +} +{ $description "Divides a number by the number of days in a 365-day year." } ; + +HELP: monthly +{ $values + { "x" number } + { "y" number } +} +{ $description "Divides a number by the number of months in a year." } ; + +HELP: semimonthly +{ $values + { "x" number } + { "y" number } +} +{ $description "Divides a number by the number of half-months in a year. Note that biweekly has two more periods than semimonthly." } ; + +HELP: weekly +{ $values + { "x" number } + { "y" number } +} +{ $description "Divides a number by the number of weeks in a year." } ; diff --git a/extra/math/finance/finance.factor b/extra/math/finance/finance.factor index e02f4be624..a1f2316c38 100644 --- a/extra/math/finance/finance.factor +++ b/extra/math/finance/finance.factor @@ -26,3 +26,14 @@ PRIVATE> : momentum ( seq n -- newseq ) [ tail-slice ] 2keep [ dup length ] dip - head-slice v- ; +: monthly ( x -- y ) 12 / ; inline + +: semimonthly ( x -- y ) 24 / ; inline + +: biweekly ( x -- y ) 26 / ; inline + +: weekly ( x -- y ) 52 / ; inline + +: daily-360 ( x -- y ) 360 / ; inline + +: daily-365 ( x -- y ) 365 / ; inline From 4a5bf7e9d18fc6faba6a7d77b9024ada4468799a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 6 Dec 2008 23:08:18 -0600 Subject: [PATCH 076/150] remove moved docs --- basis/calendar/calendar-docs.factor | 14 -------------- 1 file changed, 14 deletions(-) diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index 3d765aeed9..433459cb24 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -540,8 +540,6 @@ ARTICLE: "calendar" "Calendar" { $subsection "years" } { $subsection "months" } { $subsection "days" } -"Calculating amounts per period of time:" -{ $subsection "time-period-calculations" } "Meta-data about the calendar:" { $subsection "calendar-facts" } ; @@ -628,18 +626,6 @@ ARTICLE: "calendar-facts" "Calendar facts" { $subsection day-of-week } ; -ARTICLE: "time-period-calculations" "Calculations over periods of time" -{ $subsection monthly } -{ $subsection semimonthly } -{ $subsection biweekly } -{ $subsection weekly } -{ $subsection daily-360 } -{ $subsection daily-365 } -{ $subsection biweekly } -{ $subsection biweekly } -{ $subsection biweekly } -; - ARTICLE: "years" "Year operations" "Leap year predicate:" { $subsection leap-year? } From 3075eeb4ab4f395286004ba89622076bcb70c4a7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 6 Dec 2008 23:12:38 -0600 Subject: [PATCH 077/150] fix math docs, refactor a bit --- extra/math/finance/finance-docs.factor | 21 +++++++++++++++---- extra/math/finance/finance.factor | 2 +- .../numerical-integration.factor | 9 ++++---- 3 files changed, 23 insertions(+), 9 deletions(-) diff --git a/extra/math/finance/finance-docs.factor b/extra/math/finance/finance-docs.factor index 97e44d2927..a1e81bf665 100644 --- a/extra/math/finance/finance-docs.factor +++ b/extra/math/finance/finance-docs.factor @@ -1,8 +1,6 @@ -! Copyright (C) 2008 John Benediktsson +! Copyright (C) 2008 John Benediktsson, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license - -USING: help.markup help.syntax ; - +USING: help.markup help.syntax math ; IN: math.finance HELP: sma @@ -73,3 +71,18 @@ HELP: weekly { "y" number } } { $description "Divides a number by the number of weeks in a year." } ; + +ARTICLE: "time-period-calculations" "Calculations over periods of time" +{ $subsection monthly } +{ $subsection semimonthly } +{ $subsection biweekly } +{ $subsection weekly } +{ $subsection daily-360 } +{ $subsection daily-365 } ; + +ARTICLE: "math.finance" "Financial math" +"The " { $vocab-link "math.finance" } " vocabulary contains financial calculation words." $nl +"Calculating payroll over periods of time:" +{ $subsection "time-period-calculations" } ; + +ABOUT: "math.finance" diff --git a/extra/math/finance/finance.factor b/extra/math/finance/finance.factor index a1f2316c38..4823e358b0 100644 --- a/extra/math/finance/finance.factor +++ b/extra/math/finance/finance.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 John Benediktsson. +! Copyright (C) 2008 John Benediktsson, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs kernel grouping sequences shuffle math math.functions math.statistics math.vectors ; diff --git a/extra/math/numerical-integration/numerical-integration.factor b/extra/math/numerical-integration/numerical-integration.factor index dfaa618b53..6b46ba0243 100644 --- a/extra/math/numerical-integration/numerical-integration.factor +++ b/extra/math/numerical-integration/numerical-integration.factor @@ -4,15 +4,16 @@ USING: arrays kernel sequences namespaces make math math.ranges math.vectors vectors ; IN: math.numerical-integration -SYMBOL: num-steps 180 num-steps set-global +SYMBOL: num-steps + +180 num-steps set-global : setup-simpson-range ( from to -- frange ) 2dup swap - num-steps get / ; : generate-simpson-weights ( seq -- seq ) - { 1 4 } - swap length 2 / 2 - { 2 4 } concat - { 1 } 3append ; + length 2 / 2 - { 2 4 } concat + { 1 4 } { 1 } surround ; : integrate-simpson ( from to f -- x ) [ setup-simpson-range dup ] dip From 5d7472caf88ef2309c27a1ef5ec87021f0170f4e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 6 Dec 2008 23:38:04 -0600 Subject: [PATCH 078/150] refactor extra inverse a bit --- extra/inverse/inverse.factor | 58 +++++++++++++++++++----------------- 1 file changed, 30 insertions(+), 28 deletions(-) diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 61c5da6bca..0e3d48fe5b 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -9,14 +9,12 @@ combinators.short-circuit fry qualified ; RENAME: _ fry => __ IN: inverse -TUPLE: fail ; -: fail ( -- * ) \ fail new throw ; +ERROR: fail ; M: fail summary drop "Unification failed" ; : assure ( ? -- ) [ fail ] unless ; -: =/fail ( obj1 obj2 -- ) - = assure ; +: =/fail ( obj1 obj2 -- ) = assure ; ! Inverse of a quotation @@ -26,25 +24,26 @@ M: fail summary drop "Unification failed" ; pick 1quotation 3array "math-inverse" set-word-prop ; : define-pop-inverse ( word n quot -- ) - >r dupd "pop-length" set-word-prop r> + [ dupd "pop-length" set-word-prop ] dip "pop-inverse" set-word-prop ; -TUPLE: no-inverse word ; -: no-inverse ( word -- * ) \ no-inverse new throw ; +ERROR: no-inverse word ; M: no-inverse summary drop "The word cannot be used in pattern matching" ; +ERROR: bad-math-inverse ; + : next ( revquot -- revquot* first ) - [ "Badly formed math inverse" throw ] + [ bad-math-inverse ] [ unclip-slice ] if-empty ; : constant-word? ( word -- ? ) stack-effect - [ out>> length 1 = ] keep - in>> length 0 = and ; + [ out>> length 1 = ] + [ in>> empty? ] bi and ; : assure-constant ( constant -- quot ) - dup word? [ "Badly formed math inverse" throw ] when 1quotation ; + dup word? [ bad-math-inverse ] when 1quotation ; : swap-inverse ( math-inverse revquot -- revquot* quot ) next assure-constant rot second '[ @ swap @ ] ; @@ -55,8 +54,7 @@ M: no-inverse summary : ?word-prop ( word/object name -- value/f ) over word? [ word-prop ] [ 2drop f ] if ; -: undo-literal ( object -- quot ) - [ =/fail ] curry ; +: undo-literal ( object -- quot ) [ =/fail ] curry ; PREDICATE: normal-inverse < word "inverse" word-prop ; PREDICATE: math-inverse < word "math-inverse" word-prop ; @@ -65,13 +63,13 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ; : enough? ( stack word -- ? ) dup deferred? [ 2drop f ] [ - [ >r length r> 1quotation infer in>> >= ] + [ [ length ] dip 1quotation infer in>> >= ] [ 3drop f ] recover ] if ; : fold-word ( stack word -- stack ) 2dup enough? - [ 1quotation with-datastack ] [ >r % r> , { } ] if ; + [ 1quotation with-datastack ] [ [ % ] dip , { } ] if ; : fold ( quot -- folded-quot ) [ { } swap [ fold-word ] each % ] [ ] make ; @@ -95,13 +93,15 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ; throw ] recover ; +ERROR: undefined-inverse ; + GENERIC: inverse ( revquot word -- revquot* quot ) M: object inverse undo-literal ; M: symbol inverse undo-literal ; -M: word inverse drop "Inverse is undefined" throw ; +M: word inverse undefined-inverse ; M: normal-inverse inverse "inverse" word-prop ; @@ -112,8 +112,8 @@ M: math-inverse inverse [ drop swap-inverse ] [ pull-inverse ] if ; M: pop-inverse inverse - [ "pop-length" word-prop cut-slice swap >quotation ] keep - "pop-inverse" word-prop compose call ; + [ "pop-length" word-prop cut-slice swap >quotation ] + [ "pop-inverse" word-prop ] bi compose call ; : (undo) ( revquot -- ) [ unclip-slice inverse % (undo) ] unless-empty ; @@ -129,7 +129,7 @@ MACRO: undo ( quot -- ) [undo] ; \ dup [ [ =/fail ] keep ] define-inverse \ 2dup [ over =/fail over =/fail ] define-inverse \ 3dup [ pick =/fail pick =/fail pick =/fail ] define-inverse -\ pick [ >r pick r> =/fail ] define-inverse +\ pick [ [ pick ] dip =/fail ] define-inverse \ tuck [ swapd [ =/fail ] keep ] define-inverse \ not [ not ] define-inverse @@ -151,9 +151,12 @@ MACRO: undo ( quot -- ) [undo] ; \ sq [ sqrt ] define-inverse \ sqrt [ sq ] define-inverse +ERROR: missing-literal ; + : assert-literal ( n -- n ) - dup [ word? ] keep symbol? not and - [ "Literal missing in pattern matching" throw ] when ; + dup + [ word? ] [ symbol? not ] bi and + [ missing-literal ] when ; \ + [ - ] [ - ] define-math-inverse \ - [ + ] [ - ] define-math-inverse \ * [ / ] [ / ] define-math-inverse @@ -162,7 +165,7 @@ MACRO: undo ( quot -- ) [undo] ; \ ? 2 [ [ assert-literal ] bi@ - [ swap >r over = r> swap [ 2drop f ] [ = [ t ] [ fail ] if ] if ] + [ swap [ over = ] dip swap [ 2drop f ] [ = [ t ] [ fail ] if ] if ] 2curry ] define-pop-inverse @@ -217,7 +220,7 @@ DEFER: _ dup wrapper? [ wrapped>> ] when ; : boa-inverse ( class -- quot ) - [ deconstruct-pred ] keep slot-readers compose ; + [ deconstruct-pred ] [ slot-readers ] bi compose ; \ boa 1 [ ?wrapped boa-inverse ] define-pop-inverse @@ -232,7 +235,7 @@ DEFER: _ : recover-fail ( try fail -- ) [ drop call ] [ - >r nip r> dup fail? + [ nip ] dip dup fail? [ drop call ] [ nip throw ] if ] recover ; inline @@ -243,12 +246,11 @@ DEFER: _ in>> [ ndrop f ] curry [ recover-fail ] curry ; : [matches?] ( quot -- undoes?-quot ) - [undo] dup infer [ true-out ] keep false-recover curry ; + [undo] dup infer [ true-out ] [ false-recover ] bi curry ; MACRO: matches? ( quot -- ? ) [matches?] ; -TUPLE: no-match ; -: no-match ( -- * ) \ no-match new throw ; +ERROR: no-match ; M: no-match summary drop "Fall through in switch" ; : recover-chain ( seq -- quot ) @@ -256,7 +258,7 @@ M: no-match summary drop "Fall through in switch" ; : [switch] ( quot-alist -- quot ) [ dup quotation? [ [ ] swap 2array ] when ] map - reverse [ >r [undo] r> compose ] { } assoc>map + reverse [ [ [undo] ] dip compose ] { } assoc>map recover-chain ; MACRO: switch ( quot-alist -- ) [switch] ; From 6f058a30cabd0de74353c4a2ef3bc2f04d9235bf Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 6 Dec 2008 23:42:41 -0600 Subject: [PATCH 079/150] remove outdated readmes --- unmaintained/README.libs.txt | 88 ------------------------------------ unmaintained/README.txt | 30 ------------ 2 files changed, 118 deletions(-) delete mode 100644 unmaintained/README.libs.txt delete mode 100644 unmaintained/README.txt diff --git a/unmaintained/README.libs.txt b/unmaintained/README.libs.txt deleted file mode 100644 index fb5430ae75..0000000000 --- a/unmaintained/README.libs.txt +++ /dev/null @@ -1,88 +0,0 @@ -This directory contains Factor code that is not part of the core -library, but is useful enough to ship with the Factor distribution. - -Modules can be loaded from the listener: - - "libs/modulename" require - -Available libraries: - -- alarms -- call a quotation at a calendar date (Doug Coleman) -- alien -- Alien utility words (Eduardo Cavazos) -- base64 -- base64 encoding/decoding (Doug Coleman) -- basic-authentication -- basic authentication implementation for HTTP server (Chris Double) -- cairo -- cairo bindings (Sampo Vuori) -- calendar -- timestamp/calendar with timezones (Doug Coleman) -- canvas -- Gadget which renders an OpenGL display list (Slava Pestov) -- cocoa-callbacks -- Allows you to use Factor quotations as actions (Slava Pestov) -- concurrency -- Erlang/Termite-style distibuted concurrency (Chris Double) -- coroutines -- coroutines (Chris Double) -- cryptlib -- cryptlib binding (Elie Chaftari) -- crypto -- Various cryptographic algorithms (Doug Coleman) -- csv -- Comma-separated values parser (Daniel Ehrenberg) -- dlists -- double-linked-lists (Mackenzie Straight) -- editpadpro -- EditPadPro integration for Windows (Ryan Murphy) -- emacs -- emacs integration (Eduardo Cavazos) -- farkup -- Wiki-style markup (Matthew Willis) -- file-appender -- append to existing files (Doug Coleman) -- fjsc -- Factor to Javascript compiler (Chris Double) -- furnace -- Web framework (Slava Pestov) -- gap-buffer -- Efficient text editor buffer (Alex Chapman) -- graphics -- Graphics library in Factor (Doug Coleman) -- hardware-info -- Information about your computer (Doug Coleman) -- handler -- Gesture handler mixin (Eduardo Cavazos) -- heap -- Binary min heap implementation (Ryan Murphy) -- hexdump -- Hexdump routine (Doug Coleman) -- http -- Code shared by HTTP server and client (Slava Pestov) -- http-client -- HTTP client (Slava Pestov) -- id3 -- ID3 parser (Adam Wendt) -- io -- mmap, filesystem utils (Doug Coleman) -- jedit -- jEdit editor integration (Slava Pestov) -- jni -- Java Native Interface Wrapper (Chris Double) -- json -- JSON reader and writer (Chris Double) -- koszul -- Lie algebra cohomology and central representation (Slava Pestov) -- lazy-lists -- Lazy evaluation lists (Chris Double, Matthew Willis) -- locals -- Crappy local variables (Slava Pestov) -- mad -- Wrapper for libmad MP3 decoder (Adam Wendt) -- match -- pattern matching (Chris Double) -- math -- extended math library (Doug Coleman, Slava Pestov) -- matrices -- Matrix math (Slava Pestov) -- memoize -- memoization (caching word results) (Slava Pestov) -- mmap -- memory mapped files (Doug Coleman) -- mysql -- MySQL binding (Berlin Brown) -- null-stream -- Something akin to /dev/null (Slava Pestov) -- odbc -- Wrapper for ODBC library (Chris Double) -- ogg -- Wrapper for libogg library (Chris Double) -- openal -- Wrapper for OpenAL and alut sound libraries (Chris Double) -- oracle -- Oracle binding (Elie Chaftari) -- parser-combinators -- Haskell-style parser combinators (Chris Double) -- porter-stemmer -- Porter stemming algorithm (Slava Pestov) -- postgresql -- PostgreSQL binding (Doug Coleman) -- process -- Run external programs (Slava Pestov, Doug Coleman) -- qualified -- Qualified names for words in other vocabularies (Daniel Ehrenberg) -- rewrite-closures -- Turn quotations into closures (Eduardo Cavazos) -- scite -- SciTE editor integration (Clemens F. Hofreither) -- sequences -- Non-core sequence words (Eduardo Cavazos) -- serialize -- Binary object serialization (Chris Double) -- server -- The with-server combinator formely found in the core (Slava Pestov) -- slate -- Framework for graphical demos (Eduardo Cavazos) -- shuffle -- Shuffle words not in the core library (Chris Double) -- smtp -- SMTP client library (Elie Chaftari) -- splay-trees -- Splay trees (Mackenzie Straight) -- sqlite -- SQLite binding (Chris Double) -- state-machine -- Finite state machine abstraction (Daniel Ehrenberg) -- state-parser -- State-based parsing mechanism (Daniel Ehrenberg) -- textmate -- TextMate integration (Benjamin Pollack) -- theora -- Wrapper for libtheora library (Chris Double) -- trees -- Binary search and AVL (balanced) trees (Alex Chapman) -- usb -- Wrapper for libusb (Chris Double) -- unicode -- Partial Unicode support beyond the core (Daniel Ehrenberg) -- units -- Unit conversion (Doug Coleman) -- vars -- Alternative syntax for variables (Eduardo Cavazos) -- vim -- VIM integration (Alex Chapman) -- visitor -- Double dispatch through the visitor pattern (Daniel Ehrenberg) -- vorbis -- Wrapper for Ogg Vorbis library (Chris Double) -- x11 -- X Window System client library (Eduardo Cavazos) -- xml -- XML parser (Daniel Ehrenberg) -- xml-rpc -- XML-RPC client and server (Daniel Ehrenberg) -- yahoo -- Yahoo! automated search (Daniel Ehrenberg) diff --git a/unmaintained/README.txt b/unmaintained/README.txt deleted file mode 100644 index 91b1c5fe88..0000000000 --- a/unmaintained/README.txt +++ /dev/null @@ -1,30 +0,0 @@ -This directory contains Factor code that is not part of the core -library, but is useful enough to ship with the Factor distribution. - -Modules can be loaded from the listener: - - "apps/modulename" require - -Available applications: - -- article-manager -- Web-based content management system (Chris Double) -- automata -- Graphics demo for the UI (Eduardo Cavazos) -- benchmarks -- Various performance benchmarks (Slava Pestov) -- boids -- Graphics demo for the UI (Eduardo Cavazos) -- factory -- X11 window manager (Eduardo Cavazos) -- furnace-fjsc -- Web frontend for libs/fjsc (Chris Double) -- furnace-onigiri -- Weblog engine (Matthew Willis) -- furnace-pastebin -- demo app for Furnace (Slava Pestov) -- help-lint -- online documentation typo checker (Slava Pestov) -- icfp-2006 -- implements the icfp 2006 vm, boundvariable.org (Gavin Harrison) -- http-server -- HTTP server (Slava Pestov, Chris Double) -- lindenmayer -- L-systems tool (Eduardo Cavazos) -- lisppaste -- Lisppaste XML-RPC demo (Slava Pestov) -- ogg-player -- Ogg Vorbis (audio) and Theora (video) player (Chris Double) -- print-dataflow -- Code to print compiler dataflow IR to the console, or show it in the UI (Slava Pestov) -- random-tester -- Random compiler tester (Doug Coleman) -- rss -- An RSS1, RSS2 and Atom parser and aggregator (Chris Double, Daniel Ehrenberg) -- space-invaders -- Intel 8080-based Space Invaders arcade machine emulator (Chris Double) -- tetris -- Tetris game (Alex Chapman) -- turing -- Turing machine demo (Slava Pestov) -- wee-url -- Web app to make short URLs from long ones (Doug Coleman) From 1e53cf6c9f3572b231ce6eea3dab2df6e6c00acc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 7 Dec 2008 01:36:10 -0600 Subject: [PATCH 080/150] upper? was copy/pasted and WRONG. found with extra/lint --- basis/unicode/case/case-tests.factor | 6 ++++++ basis/unicode/case/case.factor | 15 +++++++-------- 2 files changed, 13 insertions(+), 8 deletions(-) diff --git a/basis/unicode/case/case-tests.factor b/basis/unicode/case/case-tests.factor index 6401ce201e..0083e49672 100644 --- a/basis/unicode/case/case-tests.factor +++ b/basis/unicode/case/case-tests.factor @@ -16,3 +16,9 @@ USING: unicode.case tools.test namespaces ; "lt" locale set ! Lithuanian casing tests ] with-scope + +[ t ] [ "asdf" lower? ] unit-test +[ f ] [ "asdF" lower? ] unit-test + +[ t ] [ "ASDF" upper? ] unit-test +[ f ] [ "ASDf" upper? ] unit-test diff --git a/basis/unicode/case/case.factor b/basis/unicode/case/case.factor index 932f72960a..ea1baa6e9c 100644 --- a/basis/unicode/case/case.factor +++ b/basis/unicode/case/case.factor @@ -100,11 +100,10 @@ SYMBOL: locale ! Just casing locale, or overall? : >case-fold ( string -- fold ) >upper >lower ; -: lower? ( string -- ? ) - dup >lower = ; -: upper? ( string -- ? ) - dup >lower = ; -: title? ( string -- ? ) - dup >title = ; -: case-fold? ( string -- ? ) - dup >case-fold = ; +: lower? ( string -- ? ) dup >lower = ; + +: upper? ( string -- ? ) dup >upper = ; + +: title? ( string -- ? ) dup >title = ; + +: case-fold? ( string -- ? ) dup >case-fold = ; From 0712db3a276200ae1bd4631d1fa3284e56b21835 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 7 Dec 2008 01:55:19 -0600 Subject: [PATCH 081/150] move lint from unmaintained to extra --- {unmaintained => extra}/lint/authors.txt | 0 extra/lint/lint-tests.factor | 14 ++ extra/lint/lint.factor | 173 +++++++++++++++++++++ {unmaintained => extra}/lint/summary.txt | 0 unmaintained/lint/lint-tests.factor | 18 --- unmaintained/lint/lint.factor | 182 ----------------------- 6 files changed, 187 insertions(+), 200 deletions(-) rename {unmaintained => extra}/lint/authors.txt (100%) create mode 100644 extra/lint/lint-tests.factor create mode 100644 extra/lint/lint.factor rename {unmaintained => extra}/lint/summary.txt (100%) delete mode 100644 unmaintained/lint/lint-tests.factor delete mode 100644 unmaintained/lint/lint.factor diff --git a/unmaintained/lint/authors.txt b/extra/lint/authors.txt similarity index 100% rename from unmaintained/lint/authors.txt rename to extra/lint/authors.txt diff --git a/extra/lint/lint-tests.factor b/extra/lint/lint-tests.factor new file mode 100644 index 0000000000..e2ca8816d9 --- /dev/null +++ b/extra/lint/lint-tests.factor @@ -0,0 +1,14 @@ +USING: io lint kernel math tools.test ; +IN: lint.tests + +! Don't write code like this +: lint1 ( -- ) [ "hi" print ] [ ] if ; ! when + +[ { { lint1 { [ [ ] if ] } } } ] [ \ lint1 lint-word ] unit-test + +: lint2 ( n -- n' ) 1 + ; ! 1+ +[ { [ 1 + ] } ] [ \ lint2 lint ] unit-test + +: lint3 dup -rot ; ! tuck + +[ { { lint3 { [ dup -rot ] } } } ] [ \ lint3 lint-word ] unit-test diff --git a/extra/lint/lint.factor b/extra/lint/lint.factor new file mode 100644 index 0000000000..298bea5c44 --- /dev/null +++ b/extra/lint/lint.factor @@ -0,0 +1,173 @@ +! Copyright (C) 2007, 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien alien.accessors arrays assocs +combinators.short-circuit fry hashtables html.elements io +kernel math namespaces prettyprint quotations sequences +sequences.deep sets slots.private vectors vocabs words +kernel.private ; +IN: lint + +SYMBOL: def-hash +SYMBOL: def-hash-keys + +: set-hash-vector ( val key hash -- ) + 2dup at -rot [ ?push ] 2dip set-at ; + +: more-defs ( hash -- ) + { + { -rot [ swap >r swap r> ] } + { -rot [ swap swapd ] } + { rot [ >r swap r> swap ] } + { rot [ swapd swap ] } + { over [ dup swap ] } + { tuck [ dup -rot ] } + { swapd [ >r swap r> ] } + { 2nip [ nip nip ] } + { 2drop [ drop drop ] } + { 3drop [ drop drop drop ] } + { zero? [ 0 = ] } + { pop* [ pop drop ] } + { when [ [ ] if ] } + { >boolean [ f = not ] } + } swap '[ first2 _ set-hash-vector ] each ; + +: accessor-words ( -- seq ) +{ + alien-signed-1 alien-signed-2 alien-signed-4 alien-signed-8 + alien-unsigned-1 alien-unsigned-2 alien-unsigned-4 alien-unsigned-8 + alien-unsigned-cell set-alien-signed-cell + set-alien-unsigned-1 set-alien-signed-1 set-alien-unsigned-2 + set-alien-signed-2 set-alien-unsigned-4 set-alien-signed-4 + set-alien-unsigned-8 set-alien-signed-8 + alien-cell alien-signed-cell set-alien-cell set-alien-unsigned-cell + set-alien-float alien-float +} ; + +: trivial-defs + { + [ . ] + [ get ] + [ t ] [ f ] + [ { } ] + [ 0 = ] + [ drop ] ! because of declare + [ drop f ] + [ "cdecl" ] + [ first ] [ second ] [ third ] [ fourth ] + [ ">" write-html ] [ "/>" write-html ] + } ; + +! ! Add definitions +H{ } clone def-hash set-global + +all-words [ + dup def>> dup callable? + [ def-hash get-global set-hash-vector ] [ drop ] if +] each + +! ! Remove definitions + +! Remove empty word defs +def-hash get-global [ drop empty? not ] assoc-filter + +! Remove constants [ 1 ] +[ drop { [ length 1 = ] [ first number? ] } 1&& not ] assoc-filter + +! Remove words that are their own definition +[ [ [ def>> ] [ 1quotation ] bi = not ] filter ] assoc-map + +! Remove set-alien-cell, etc. +[ drop [ accessor-words diff ] keep [ length ] bi@ = ] assoc-filter + +! Remove trivial defs +[ drop trivial-defs member? not ] assoc-filter + +! Remove tag defs +[ + drop { + [ length 3 = ] + [ first \ tag = ] [ second number? ] [ third \ eq? = ] + } 1&& not +] assoc-filter + +[ + drop { + [ [ wrapper? ] deep-contains? ] + [ [ hashtable? ] deep-contains? ] + } 1|| not +] assoc-filter + +! Remove n m shift defs +[ + drop dup length 3 = [ + [ first2 [ number? ] both? ] + [ third \ shift = ] bi and not + ] [ drop t ] if +] assoc-filter + +! Remove [ n slot ] +[ + drop dup length 2 = + [ first2 [ number? ] [ \ slot = ] bi* and not ] [ drop t ] if +] assoc-filter + + +dup more-defs + +[ def-hash set-global ] [ keys def-hash-keys set-global ] bi + +: find-duplicates ( -- seq ) + def-hash get-global [ nip length 1 > ] assoc-filter ; + +GENERIC: lint ( obj -- seq ) + +M: object lint ( obj -- seq ) drop f ; + +: subseq/member? ( subseq/member seq -- ? ) + { [ start ] [ member? ] } 2|| ; + +M: callable lint ( quot -- seq ) + [ def-hash-keys get-global ] dip '[ _ subseq/member? ] filter ; + +M: word lint ( word -- seq ) + def>> dup callable? [ lint ] [ drop f ] if ; + +: word-path. ( word -- ) + [ vocabulary>> ] [ unparse ] bi ":" glue print ; + +: 4bl ( -- ) bl bl bl bl ; + +: (lint.) ( pair -- ) + first2 [ word-path. ] dip [ + [ 4bl . "-----------------------------------" print ] + [ def-hash get-global at [ 4bl word-path. ] each nl ] bi + ] each nl nl ; + +: lint. ( alist -- ) [ (lint.) ] each ; + +GENERIC: run-lint ( obj -- obj ) + +: (trim-self) ( val key -- obj ? ) + def-hash get-global at* + [ dupd remove empty? not ] [ drop f ] if ; + +: trim-self ( seq -- newseq ) + [ [ (trim-self) ] filter ] assoc-map ; + +: filter-symbols ( alist -- alist ) + [ + nip first dup def-hash get-global at + [ first ] bi@ literalize = not + ] assoc-filter ; + +M: sequence run-lint ( seq -- seq ) + [ dup lint ] { } map>assoc trim-self + [ second empty? not ] filter filter-symbols ; + +M: word run-lint ( word -- seq ) 1array run-lint ; + +: lint-all ( -- seq ) all-words run-lint dup lint. ; + +: lint-vocab ( vocab -- seq ) words run-lint dup lint. ; + +: lint-word ( word -- seq ) 1array run-lint dup lint. ; diff --git a/unmaintained/lint/summary.txt b/extra/lint/summary.txt similarity index 100% rename from unmaintained/lint/summary.txt rename to extra/lint/summary.txt diff --git a/unmaintained/lint/lint-tests.factor b/unmaintained/lint/lint-tests.factor deleted file mode 100644 index 9a39980c9f..0000000000 --- a/unmaintained/lint/lint-tests.factor +++ /dev/null @@ -1,18 +0,0 @@ -USING: io lint kernel math tools.test ; -IN: lint.tests - -! Don't write code like this -: lint1 - [ "hi" print ] [ ] if ; ! when - -[ { [ [ ] if ] } ] [ \ lint1 lint ] unit-test - -: lint2 - 1 + ; ! 1+ -[ { [ 1 + ] } ] [ \ lint2 lint ] unit-test - -: lint3 - dup -rot ; ! tuck - -[ { [ dup -rot ] } ] [ \ lint3 lint ] unit-test - diff --git a/unmaintained/lint/lint.factor b/unmaintained/lint/lint.factor deleted file mode 100644 index ab1a67a83e..0000000000 --- a/unmaintained/lint/lint.factor +++ /dev/null @@ -1,182 +0,0 @@ -! Copyright (C) 2007 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien alien.accessors arrays assocs -combinators.lib io kernel macros math namespaces prettyprint -quotations sequences vectors vocabs words html.elements sets -slots.private combinators.short-circuit math.order hashtables -sequences.deep ; -IN: lint - -SYMBOL: def-hash -SYMBOL: def-hash-keys - -: set-hash-vector ( val key hash -- ) - 2dup at -rot [ ?push ] 2dip set-at ; - -: add-word-def ( word quot -- ) - dup callable? [ - def-hash get-global set-hash-vector - ] [ - 2drop - ] if ; - -: more-defs ( -- ) - { - { [ swap >r swap r> ] -rot } - { [ swap swapd ] -rot } - { [ >r swap r> swap ] rot } - { [ swapd swap ] rot } - { [ dup swap ] over } - { [ dup -rot ] tuck } - { [ >r swap r> ] swapd } - { [ nip nip ] 2nip } - { [ drop drop ] 2drop } - { [ drop drop drop ] 3drop } - { [ 0 = ] zero? } - { [ pop drop ] pop* } - { [ [ ] if ] when } - { [ f = not ] >boolean } - } [ first2 swap add-word-def ] each ; - -: accessor-words ( -- seq ) -{ - alien-signed-1 alien-signed-2 alien-signed-4 alien-signed-8 - alien-unsigned-1 alien-unsigned-2 alien-unsigned-4 alien-unsigned-8 - alien-unsigned-cell set-alien-signed-cell - set-alien-unsigned-1 set-alien-signed-1 set-alien-unsigned-2 - set-alien-signed-2 set-alien-unsigned-4 set-alien-signed-4 - set-alien-unsigned-8 set-alien-signed-8 - alien-cell alien-signed-cell set-alien-cell set-alien-unsigned-cell - set-alien-float alien-float -} ; - -: trivial-defs - { - [ get ] [ t ] [ { } ] [ . ] [ drop f ] - [ drop ] [ f ] [ first ] [ second ] [ third ] [ fourth ] - [ ">" write-html ] [ "/>" write-html ] - } ; - -H{ } clone def-hash set-global -all-words [ dup def>> add-word-def ] each -more-defs - -! Remove empty word defs -def-hash get-global [ - drop empty? not -] assoc-filter - -! Remove constants [ 1 ] -[ - drop { [ length 1 = ] [ first number? ] } 1&& not -] assoc-filter - -! Remove set-alien-cell, etc. -[ - drop [ accessor-words diff ] keep [ length ] bi@ = -] assoc-filter - -! Remove trivial defs -[ - drop trivial-defs member? not -] assoc-filter - -[ - drop { - [ [ wrapper? ] deep-contains? ] - [ [ hashtable? ] deep-contains? ] - } 1|| not -] assoc-filter - -! Remove n m shift defs -[ - drop dup length 3 = [ - dup first2 [ number? ] both? - swap third \ shift = and not - ] [ drop t ] if -] assoc-filter - -! Remove [ n slot ] -[ - drop dup length 2 = [ - first2 \ slot = swap number? and not - ] [ drop t ] if -] assoc-filter def-hash set-global - -: find-duplicates ( -- seq ) - def-hash get-global [ - nip length 1 > - ] assoc-filter ; - -def-hash get-global keys def-hash-keys set-global - -GENERIC: lint ( obj -- seq ) - -M: object lint ( obj -- seq ) - drop f ; - -: subseq/member? ( subseq/member seq -- ? ) - { [ start ] [ member? ] } 2|| ; - -M: callable lint ( quot -- seq ) - def-hash-keys get [ - swap subseq/member? - ] with filter ; - -M: word lint ( word -- seq ) - def>> dup callable? [ lint ] [ drop f ] if ; - -: word-path. ( word -- ) - [ vocabulary>> ":" ] keep unparse 3append write nl ; - -: (lint.) ( pair -- ) - first2 >r word-path. r> [ - bl bl bl bl - dup . - "-----------------------------------" print - def-hash get at [ bl bl bl bl word-path. ] each - nl - ] each nl nl ; - -: lint. ( alist -- ) - [ (lint.) ] each ; - - -GENERIC: run-lint ( obj -- obj ) - -: (trim-self) ( val key -- obj ? ) - def-hash get-global at* [ - dupd remove empty? not - ] [ - drop f - ] if ; - -: trim-self ( seq -- newseq ) - [ [ (trim-self) ] filter ] assoc-map ; - -: filter-symbols ( alist -- alist ) - [ - nip first dup def-hash get at - [ first ] bi@ literalize = not - ] assoc-filter ; - -M: sequence run-lint ( seq -- seq ) - [ - global [ dup . flush ] bind - dup lint - ] { } map>assoc - trim-self - [ second empty? not ] filter - filter-symbols ; - -M: word run-lint ( word -- seq ) - 1array run-lint ; - -: lint-all ( -- seq ) - all-words run-lint dup lint. ; - -: lint-vocab ( vocab -- seq ) - words run-lint dup lint. ; - -: lint-word ( word -- seq ) - 1array run-lint dup lint. ; From 0190ce5b488ecdb0507147da95f1bb24b1458eb3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 7 Dec 2008 01:59:38 -0600 Subject: [PATCH 082/150] remove bogus equality --- extra/lint/lint.factor | 2 -- 1 file changed, 2 deletions(-) diff --git a/extra/lint/lint.factor b/extra/lint/lint.factor index 298bea5c44..a8320c1464 100644 --- a/extra/lint/lint.factor +++ b/extra/lint/lint.factor @@ -25,7 +25,6 @@ SYMBOL: def-hash-keys { 2nip [ nip nip ] } { 2drop [ drop drop ] } { 3drop [ drop drop drop ] } - { zero? [ 0 = ] } { pop* [ pop drop ] } { when [ [ ] if ] } { >boolean [ f = not ] } @@ -49,7 +48,6 @@ SYMBOL: def-hash-keys [ get ] [ t ] [ f ] [ { } ] - [ 0 = ] [ drop ] ! because of declare [ drop f ] [ "cdecl" ] From 68108818fd2a8d2b2f4bcd7bab4dd18d7ee1f4af Mon Sep 17 00:00:00 2001 From: William Schlieper Date: Sun, 7 Dec 2008 04:06:52 -0500 Subject: [PATCH 083/150] irc.ui: Fixed mode stuff --- extra/irc/ui/ui.factor | 39 ++++++++++++++++++++------------------- 1 file changed, 20 insertions(+), 19 deletions(-) diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index b96d3e1bdc..fd64e9a07e 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -9,7 +9,7 @@ USING: accessors kernel threads combinators concurrency.mailboxes ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels io io.styles namespaces calendar calendar.format models continuations irc.client irc.client.private irc.messages - irc.ui.commandparser irc.ui.load vocabs.loader ; + irc.ui.commandparser irc.ui.load vocabs.loader classes prettyprint ; RENAME: join sequences => sjoin @@ -30,6 +30,7 @@ TUPLE: irc-tab < frame chat client window ; foreground associate format ; : dark-red T{ rgba f 0.5 0.0 0.0 1 } ; : dark-green T{ rgba f 0.0 0.5 0.0 1 } ; +: dark-blue T{ rgba f 0.0 0.0 0.5 1 } ; : dot-or-parens ( string -- string ) [ "." ] @@ -41,14 +42,14 @@ M: ping write-irc drop "* Ping" blue write-color ; M: privmsg write-irc - "<" blue write-color + "<" dark-blue write-color [ irc-message-sender write ] keep - "> " blue write-color + "> " dark-blue write-color trailing>> write ; M: notice write-irc - [ type>> blue write-color ] keep - ": " blue write-color + [ type>> dark-blue write-color ] keep + ": " dark-blue write-color trailing>> write ; TUPLE: own-message message nick timestamp ; @@ -57,9 +58,9 @@ TUPLE: own-message message nick timestamp ; now own-message boa ; M: own-message write-irc - "<" blue write-color + "<" dark-blue write-color [ nick>> bold font-style associate format ] keep - "> " blue write-color + "> " dark-blue write-color message>> write ; M: join write-irc @@ -87,26 +88,23 @@ M: kick write-irc " from the channel" dark-red write-color trailing>> dot-or-parens dark-red write-color ; -: full-mode ( message -- mode ) - parameters>> rest " " sjoin ; - M: mode write-irc - "* " blue write-color - [ irc-message-sender write ] keep - " has applied mode " blue write-color - [ full-mode write ] keep - " to " blue write-color - channel>> write ; + "* " dark-blue write-color + [ name>> write ] keep + " has applied mode " dark-blue write-color + [ mode>> write ] keep + " to " dark-blue write-color + parameter>> write ; M: nick write-irc - "* " blue write-color + "* " dark-blue write-color [ irc-message-sender write ] keep " is now known as " blue write-color trailing>> write ; M: unhandled write-irc "UNHANDLED: " write - line>> blue write-color ; + line>> dark-blue write-color ; M: irc-end write-irc drop "* You have left IRC" dark-red write-color ; @@ -121,7 +119,10 @@ M: irc-chat-end write-irc drop ; M: irc-message write-irc - drop ; ! catch all unimplemented writes, THIS WILL CHANGE + "UNIMPLEMENTED" write + [ class pprint ] keep + ": " write + line>> dark-blue write-color ; GENERIC: time-happened ( message -- timestamp ) From 9ec5896a3afe7ca001d7bbe85bfeecdb43666ca8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 7 Dec 2008 08:39:16 -0600 Subject: [PATCH 084/150] Move two unit tests --- basis/calendar/calendar-tests.factor | 2 -- extra/math/finance/finance-tests.factor | 1 + extra/taxes/usa/usa-tests.factor | 2 +- 3 files changed, 2 insertions(+), 3 deletions(-) diff --git a/basis/calendar/calendar-tests.factor b/basis/calendar/calendar-tests.factor index 943ba8c3d5..00d5730745 100644 --- a/basis/calendar/calendar-tests.factor +++ b/basis/calendar/calendar-tests.factor @@ -167,5 +167,3 @@ IN: calendar.tests [ t ] [ now 50 milliseconds sleep now before? ] unit-test [ t ] [ now 50 milliseconds sleep now swap after? ] unit-test [ t ] [ now 50 milliseconds sleep now 50 milliseconds sleep now swapd between? ] unit-test - -[ 4+1/6 ] [ 100 semimonthly ] unit-test diff --git a/extra/math/finance/finance-tests.factor b/extra/math/finance/finance-tests.factor index dce701bb2f..fc4ad0d07e 100644 --- a/extra/math/finance/finance-tests.factor +++ b/extra/math/finance/finance-tests.factor @@ -6,3 +6,4 @@ IN: math.finance.tests [ { 1 3 1 } ] [ { 1 3 2 6 3 } 2 momentum ] unit-test +[ 4+1/6 ] [ 100 semimonthly ] unit-test diff --git a/extra/taxes/usa/usa-tests.factor b/extra/taxes/usa/usa-tests.factor index 002299fef1..6c12a423eb 100644 --- a/extra/taxes/usa/usa-tests.factor +++ b/extra/taxes/usa/usa-tests.factor @@ -1,6 +1,6 @@ USING: kernel money tools.test taxes.usa taxes.usa.federal taxes.usa.mn -calendar taxes.usa.w4 usa-cities ; +calendar taxes.usa.w4 usa-cities math.finance ; IN: taxes.usa.tests [ From ce269c87335b75de94560f5932f1a52674f598a3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 7 Dec 2008 08:50:59 -0600 Subject: [PATCH 085/150] Fix grouping unit test --- basis/grouping/grouping-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/grouping/grouping-tests.factor b/basis/grouping/grouping-tests.factor index dc3d970fbf..cfcc653776 100644 --- a/basis/grouping/grouping-tests.factor +++ b/basis/grouping/grouping-tests.factor @@ -5,7 +5,7 @@ IN: grouping.tests [ { "hell" "o wo" "rld" } ] [ "hello world" 4 group ] unit-test -[ { V{ "a" "b" } V{ f f } } ] [ +[ { V{ "a" "b" } V{ 0 0 } } ] [ V{ "a" "b" } clone 2 2 over set-length >array From d1744fd67a707bd8d603f34c7aabdd0adc668948 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 7 Dec 2008 08:51:22 -0600 Subject: [PATCH 086/150] Remove cache-nth word, nobody was using it and the semantics were broken --- core/sequences/sequences-docs.factor | 6 ------ core/sequences/sequences-tests.factor | 10 ---------- core/sequences/sequences.factor | 7 ------- 3 files changed, 23 deletions(-) diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 08831579bb..0b3e0003ac 100644 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -416,11 +416,6 @@ HELP: interleave { $description "Applies " { $snippet "quot" } " to each element in turn, also invoking " { $snippet "between" } " in-between each pair of elements." } { $example "USING: io sequences ;" "{ \"a\" \"b\" \"c\" } [ \"X\" write ] [ write ] interleave" "aXbXc" } ; -HELP: cache-nth -{ $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" { $quotation "( i -- elt )" } } { "elt" object } } -{ $description "If the sequence does not contain at least " { $snippet "i" } " elements or if the " { $snippet "i" } "th element of the sequence is " { $link f } ", calls the quotation to produce a new value, and stores it back into the sequence. Otherwise, this word outputs the " { $snippet "i" } "th element of the sequence." } -{ $side-effects "seq" } ; - HELP: index { $values { "obj" object } { "seq" sequence } { "n" "an index" } } { $description "Outputs the index of the first element in the sequence equal to " { $snippet "obj" } ". If no element is found, outputs " { $link f } "." } ; @@ -1497,7 +1492,6 @@ ARTICLE: "sequences-destructive" "Destructive operations" "Changing elements:" { $subsection change-each } { $subsection change-nth } -{ $subsection cache-nth } "Deleting elements:" { $subsection delete } { $subsection delq } diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 0d795d453a..dcca525e2b 100644 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -190,16 +190,6 @@ unit-test [ V{ "a" "b" } V{ } ] [ { "X" "a" "b" } { "X" } drop-prefix [ >vector ] bi@ ] unit-test -[ 1 4 9 16 16 V{ f 1 4 9 16 } ] [ - V{ } clone "cache-test" set - 1 "cache-test" get [ sq ] cache-nth - 2 "cache-test" get [ sq ] cache-nth - 3 "cache-test" get [ sq ] cache-nth - 4 "cache-test" get [ sq ] cache-nth - 4 "cache-test" get [ "wrong" ] cache-nth - "cache-test" get -] unit-test - [ 1 ] [ 0.5 { 1 2 3 } nth ] unit-test ! Pathological case diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 995a8bba4c..8c9eff94f5 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -523,13 +523,6 @@ PRIVATE> : harvest ( seq -- newseq ) [ empty? not ] filter ; -: cache-nth ( i seq quot -- elt ) - 2over ?nth dup [ - [ 3drop ] dip - ] [ - drop swap [ over [ call dup ] dip ] dip set-nth - ] if ; inline - : mismatch ( seq1 seq2 -- i ) [ min-length ] 2keep [ 2nth-unsafe = not ] 2curry From ad4729712c46327d566b3bea3d9d226fad264602 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 7 Dec 2008 17:21:15 -0600 Subject: [PATCH 087/150] remove combinators that nobody uses --- extra/combinators/lib/lib.factor | 9 --------- 1 file changed, 9 deletions(-) diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index ac8c3d11d8..5e78d183b0 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -116,18 +116,9 @@ MACRO: construct-slots ( assoc tuple-class -- tuple ) [ dip ] curry swap 1quotation [ keep ] curry compose ] { } assoc>map concat compose ; -: either ( object first second -- ? ) - >r keep swap [ r> drop ] [ r> call ] ?if ; inline - : 2quot-with ( obj seq quot1 quot2 -- seq quot1 quot2 ) >r pick >r with r> r> swapd with ; -: or? ( obj quot1 quot2 -- ? ) - [ keep ] dip rot [ 2nip ] [ call ] if* ; inline - -: and? ( obj quot1 quot2 -- ? ) - [ keep ] dip rot [ call ] [ 2drop f ] if ; inline - MACRO: multikeep ( word out-indexes -- ... ) [ dup >r [ \ npick \ >r 3array % ] each From ce00c953847e8680158882209acade3e13735d02 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 7 Dec 2008 17:22:05 -0600 Subject: [PATCH 088/150] remove some trivial definitions from lint --- extra/lint/lint.factor | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/extra/lint/lint.factor b/extra/lint/lint.factor index a8320c1464..77b0b11238 100644 --- a/extra/lint/lint.factor +++ b/extra/lint/lint.factor @@ -44,11 +44,13 @@ SYMBOL: def-hash-keys : trivial-defs { + [ drop ] [ 2array ] + [ bitand ] + [ . ] [ get ] [ t ] [ f ] [ { } ] - [ drop ] ! because of declare [ drop f ] [ "cdecl" ] [ first ] [ second ] [ third ] [ fourth ] @@ -80,6 +82,12 @@ def-hash get-global [ drop empty? not ] assoc-filter ! Remove trivial defs [ drop trivial-defs member? not ] assoc-filter +! Remove numbers only defs +[ drop [ number? ] all? not ] assoc-filter + +! Remove curry only defs +[ drop [ \ curry = ] all? not ] assoc-filter + ! Remove tag defs [ drop { From e4f8448eb140f2ab8e399675e74fb53e897cd152 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 7 Dec 2008 19:44:49 -0600 Subject: [PATCH 089/150] Fix some problems with arithmetic type inference, exposed by recent changes to log2 word - declared input type for bignum-shift was stricter than the runtime behavior, leading to bad propagation of type info if shift count was a bignum - types inferred for type functions which used number-valued/integer-valued/real-valued were not always precise, eg bignum bignum bitxor => integer - add interval-log2, type function for (log2) - remove math-class-min, it was useless --- basis/compiler/tests/optimizer.factor | 6 ++ .../known-words/known-words.factor | 33 ++++--- .../tree/propagation/propagation-tests.factor | 90 +++++++++++++------ basis/math/intervals/intervals-docs.factor | 7 +- basis/math/intervals/intervals.factor | 16 +++- core/generic/math/math.factor | 3 - core/math/integers/integers.factor | 5 +- core/math/math.factor | 5 +- vm/math.c | 2 +- 9 files changed, 116 insertions(+), 51 deletions(-) diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 41df6e7ae5..fa6a3c7b21 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -375,3 +375,9 @@ DEFER: loop-bbb : loop-ccc ( -- ) loop-bbb ; [ 0 ] [ 0 counter set loop-ccc counter get ] unit-test + +! Type inference issue +[ 4 3 ] [ + 1 >bignum 2 >bignum + [ { bignum integer } declare [ shift ] keep 1+ ] compile-call +] unit-test diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 8242311287..4d8d935477 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -1,11 +1,12 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel effects accessors math math.private math.libm -math.partial-dispatch math.intervals math.parser math.order -layouts words sequences sequences.private arrays assocs classes -classes.algebra combinators generic.math splitting fry locals -classes.tuple alien.accessors classes.tuple.private slots.private -definitions strings.private vectors hashtables +USING: kernel effects accessors math math.private +math.integers.private math.partial-dispatch math.intervals +math.parser math.order layouts words sequences sequences.private +arrays assocs classes classes.algebra combinators generic.math +splitting fry locals classes.tuple alien.accessors +classes.tuple.private slots.private definitions strings.private +vectors hashtables stack-checker.state compiler.tree.comparisons compiler.tree.propagation.info @@ -76,14 +77,17 @@ most-negative-fixnum most-positive-fixnum [a,b] [ rational math-class-max ] dip ] unless ; +: ensure-math-class ( class must-be -- class' ) + [ class<= ] 2keep ? ; + : number-valued ( class interval -- class' interval' ) - [ number math-class-min ] dip ; + [ number ensure-math-class ] dip ; : integer-valued ( class interval -- class' interval' ) - [ integer math-class-min ] dip ; + [ integer ensure-math-class ] dip ; : real-valued ( class interval -- class' interval' ) - [ real math-class-min ] dip ; + [ real ensure-math-class ] dip ; : float-valued ( class interval -- class' interval' ) over null-class? [ @@ -230,7 +234,7 @@ generic-comparison-ops [ } [ [ in-d>> second value-info >literal< - [ power-of-2? [ 1- bitand ] f ? ] when + [ dup integer? [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ] when ] "custom-inlining" set-word-prop ] each @@ -247,6 +251,15 @@ generic-comparison-ops [ ] "custom-inlining" set-word-prop ] each +{ numerator denominator } +[ [ drop integer ] "outputs" set-word-prop ] each + +{ (log2) fixnum-log2 bignum-log2 } [ + [ + [ class>> ] [ interval>> interval-log2 ] bi + ] "outputs" set-word-prop +] each + \ string-nth [ 2drop fixnum 0 23 2^ [a,b] ] "outputs" set-word-prop diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index aa04b58de7..d95245fe83 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -34,17 +34,57 @@ IN: compiler.tree.propagation.tests [ V{ fixnum } ] [ [ { fixnum } declare bitnot ] final-classes ] unit-test -[ V{ number } ] [ [ + ] final-classes ] unit-test +! Test type propagation for math ops +: cleanup-math-class ( obj -- class ) + { null fixnum bignum integer ratio rational float real complex number } + [ class= ] with find nip ; -[ V{ float } ] [ [ { float integer } declare + ] final-classes ] unit-test +: final-math-class ( quot -- class ) + final-classes first cleanup-math-class ; -[ V{ float } ] [ [ /f ] final-classes ] unit-test +[ number ] [ [ + ] final-math-class ] unit-test -[ V{ integer } ] [ [ /i ] final-classes ] unit-test +[ bignum ] [ [ { fixnum bignum } declare + ] final-math-class ] unit-test -[ V{ integer } ] [ - [ { integer } declare bitnot ] final-classes -] unit-test +[ integer ] [ [ { fixnum integer } declare + ] final-math-class ] unit-test + +[ bignum ] [ [ { integer bignum } declare + ] final-math-class ] unit-test + +[ integer ] [ [ { fixnum fixnum } declare + ] final-math-class ] unit-test + +[ float ] [ [ { float integer } declare + ] final-math-class ] unit-test + +[ float ] [ [ { real float } declare + ] final-math-class ] unit-test + +[ float ] [ [ { float real } declare + ] final-math-class ] unit-test + +[ rational ] [ [ { ratio ratio } declare + ] final-math-class ] unit-test + +[ rational ] [ [ { rational ratio } declare + ] final-math-class ] unit-test + +[ number ] [ [ { complex complex } declare + ] final-math-class ] unit-test + +[ float ] [ [ /f ] final-math-class ] unit-test + +[ float ] [ [ { real real } declare /f ] final-math-class ] unit-test + +[ integer ] [ [ /i ] final-math-class ] unit-test + +[ integer ] [ [ { integer float } declare /i ] final-math-class ] unit-test + +[ integer ] [ [ { float float } declare /i ] final-math-class ] unit-test + +[ integer ] [ [ { integer } declare bitnot ] final-math-class ] unit-test + +[ null ] [ [ { null null } declare + ] final-math-class ] unit-test + +[ null ] [ [ { null fixnum } declare + ] final-math-class ] unit-test + +[ float ] [ [ { float fixnum } declare + ] final-math-class ] unit-test + +[ bignum ] [ [ { bignum bignum } declare bitxor ] final-math-class ] unit-test + +[ float ] [ [ { float float } declare mod ] final-math-class ] unit-test [ V{ integer } ] [ [ 255 bitand ] final-classes ] unit-test @@ -66,18 +106,6 @@ IN: compiler.tree.propagation.tests [ { fixnum } declare 615949 * ] final-classes ] unit-test -[ V{ null } ] [ - [ { null null } declare + ] final-classes -] unit-test - -[ V{ null } ] [ - [ { null fixnum } declare + ] final-classes -] unit-test - -[ V{ float } ] [ - [ { float fixnum } declare + ] final-classes -] unit-test - [ V{ fixnum } ] [ [ 255 bitand >fixnum 3 bitor ] final-classes ] unit-test @@ -279,14 +307,6 @@ IN: compiler.tree.propagation.tests ] final-classes ] unit-test -[ V{ float } ] [ - [ { real float } declare + ] final-classes -] unit-test - -[ V{ float } ] [ - [ { float real } declare + ] final-classes -] unit-test - [ V{ fixnum } ] [ [ { fixnum fixnum } declare 7 bitand neg shift ] final-classes ] unit-test @@ -604,6 +624,22 @@ MIXIN: empty-mixin [ { integer } declare 127 bitand ] final-info first interval>> ] unit-test +[ V{ bignum } ] [ + [ { bignum } declare dup 1- bitxor ] final-classes +] unit-test + +[ V{ bignum integer } ] [ + [ { bignum integer } declare [ shift ] keep ] final-classes +] unit-test + +[ V{ fixnum } ] [ + [ { fixnum } declare log2 ] final-classes +] unit-test + +[ V{ word } ] [ + [ { fixnum } declare log2 0 >= ] final-classes +] unit-test + ! [ V{ string } ] [ ! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes ! ] unit-test diff --git a/basis/math/intervals/intervals-docs.factor b/basis/math/intervals/intervals-docs.factor index 5a96c7aceb..d8a80340ba 100644 --- a/basis/math/intervals/intervals-docs.factor +++ b/basis/math/intervals/intervals-docs.factor @@ -44,7 +44,8 @@ ARTICLE: "math-intervals-arithmetic" "Interval arithmetic" { $subsection interval-bitnot } { $subsection interval-recip } { $subsection interval-2/ } -{ $subsection interval-abs } ; +{ $subsection interval-abs } +{ $subsection interval-log2 } ; ARTICLE: "math-intervals-sets" "Set-theoretic operations on intervals" { $subsection interval-contains? } @@ -203,6 +204,10 @@ HELP: interval-abs { $values { "i1" interval } { "i2" interval } } { $description "Absolute value of an interval." } ; +HELP: interval-log2 +{ $values { "i1" interval } { "i2" interval } } +{ $description "Integer-valued Base-2 logarithm of an interval." } ; + HELP: interval-intersect { $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } } { $description "Outputs the set-theoretic intersection of " { $snippet "i1" } " and " { $snippet "i2" } ". If " { $snippet "i1" } " and " { $snippet "i2" } " do not intersect, outputs " { $link f } "." } ; diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor index 4182d25524..ed76ccaedd 100644 --- a/basis/math/intervals/intervals.factor +++ b/basis/math/intervals/intervals.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! Based on Slate's src/unfinished/interval.slate by Brian Rice. USING: accessors kernel sequences arrays math math.order -combinators generic ; +combinators generic layouts ; IN: math.intervals SYMBOL: empty-interval @@ -365,7 +365,7 @@ SYMBOL: incomparable 2dup [ interval-nonnegative? ] both? [ [ interval>points [ first ] bi@ ] bi@ - 4array supremum 0 swap next-power-of-2 [a,b] + 4array supremum 0 swap >integer next-power-of-2 [a,b] ] [ 2drop [-inf,inf] ] if ] do-empty-interval ; @@ -373,6 +373,18 @@ SYMBOL: incomparable #! Inaccurate. interval-bitor ; +: interval-log2 ( i1 -- i2 ) + { + { empty-interval [ empty-interval ] } + { full-interval [ 0 [a,inf] ] } + [ + to>> first 1 max dup most-positive-fixnum > + [ drop full-interval interval-log2 ] + [ 1+ >integer log2 0 swap [a,b] ] + if + ] + } case ; + : assume< ( i1 i2 -- i3 ) dup special-interval? [ drop ] [ to>> first [-inf,a) interval-intersect diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 63043b50b9..66f2da7191 100644 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -28,9 +28,6 @@ PREDICATE: math-class < class : math-class-max ( class1 class2 -- class ) [ math-class<=> ] most ; -: math-class-min ( class1 class2 -- class ) - [ swap math-class<=> ] most ; - : (math-upgrade) ( max class -- quot ) dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ; diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index 910d394c55..30903e3269 100644 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -45,9 +45,6 @@ M: fixnum bit? neg shift 1 bitand 0 > ; M: fixnum (log2) fixnum-log2 ; -M: integer next-power-of-2 - dup 2 <= [ drop 2 ] [ 1- log2 1+ 2^ ] if ; - M: bignum >fixnum bignum>fixnum ; M: bignum >bignum ; @@ -76,7 +73,7 @@ M: bignum /mod bignum/mod ; M: bignum bitand bignum-bitand ; M: bignum bitor bignum-bitor ; M: bignum bitxor bignum-bitxor ; -M: bignum shift bignum-shift ; +M: bignum shift >fixnum bignum-shift ; M: bignum bitnot bignum-bitnot ; M: bignum bit? bignum-bit? ; diff --git a/core/math/math.factor b/core/math/math.factor index 8b064725d3..2434bf8ec6 100644 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -103,9 +103,8 @@ M: float fp-infinity? ( float -- ? ) drop f ] if ; -GENERIC: next-power-of-2 ( m -- n ) foldable - -M: real next-power-of-2 1+ >integer next-power-of-2 ; +: next-power-of-2 ( m -- n ) + dup 2 <= [ drop 2 ] [ 1- log2 1+ 2^ ] if ; inline : power-of-2? ( n -- ? ) dup 0 <= [ drop f ] [ dup 1- bitand zero? ] if ; foldable diff --git a/vm/math.c b/vm/math.c index dd01e852ad..f0aa874886 100644 --- a/vm/math.c +++ b/vm/math.c @@ -197,7 +197,7 @@ void primitive_bignum_xor(void) void primitive_bignum_shift(void) { - F_FIXNUM y = to_fixnum(dpop()); + F_FIXNUM y = untag_fixnum_fast(dpop()); F_ARRAY* x = untag_object(dpop()); dpush(tag_bignum(bignum_arithmetic_shift(x,y))); } From 819239edb9718c9149cbad1cdf33c6b0db5e06ae Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 7 Dec 2008 23:51:13 -0600 Subject: [PATCH 090/150] add file-systems. word --- basis/tools/files/files.factor | 35 ++++++++++++++++++++++++++++++++-- 1 file changed, 33 insertions(+), 2 deletions(-) diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor index 58c24ef6ca..18baedae0a 100755 --- a/basis/tools/files/files.factor +++ b/basis/tools/files/files.factor @@ -1,14 +1,15 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators io io.files kernel -math.parser sequences system vocabs.loader calendar ; +math.parser sequences system vocabs.loader calendar math +symbols fry prettyprint ; IN: tools.files > ] [ minute>> ] bi - [ number>string 2 CHAR: 0 pad-left ] bi@ ":" swap 3append ; + [ number>string 2 CHAR: 0 pad-left ] bi@ ":" glue ; : ls-timestamp ( timestamp -- string ) [ month>> month-abbreviation ] @@ -32,7 +33,37 @@ PRIVATE> : directory. ( path -- ) [ (directory.) ] with-directory-files [ print ] each ; +SYMBOLS: device-name mount-point type +available-space free-space used-space total-space +percent-used percent-free ; + +: percent ( real -- integer ) 100 * >integer ; inline + +: file-system-spec ( file-system-info obj -- str ) + { + { device-name [ device-name>> ] } + { mount-point [ mount-point>> ] } + { type [ type>> ] } + { available-space [ available-space>> ] } + { free-space [ free-space>> ] } + { used-space [ used-space>> ] } + { total-space [ total-space>> ] } + { percent-used [ + [ used-space>> ] [ total-space>> ] bi dup 0 = + [ 2drop 0 ] [ / percent ] if + ] } + } case ; + +: file-systems-info ( spec -- seq ) + file-systems swap '[ _ [ file-system-spec ] with map ] map ; + +: file-systems. ( spec -- ) + [ file-systems-info ] + [ [ unparse ] map ] bi prefix simple-table. ; + { { [ os unix? ] [ "tools.files.unix" ] } { [ os windows? ] [ "tools.files.windows" ] } } cond require + +! { device-name free-space used-space total-space percent-used } file-systems. From 24c9337db6c29f65a3c124a60285a6308297f955 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 8 Dec 2008 00:05:52 -0600 Subject: [PATCH 091/150] remove >r r> --- basis/state-parser/state-parser.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/state-parser/state-parser.factor b/basis/state-parser/state-parser.factor index dab5414b49..9341f39426 100644 --- a/basis/state-parser/state-parser.factor +++ b/basis/state-parser/state-parser.factor @@ -139,7 +139,7 @@ M: not-enough-characters summary ( obj -- str ) : expect ( ch -- ) get-char 2dup = [ 2drop ] [ - >r 1string r> 1string expected + [ 1string ] bi@ expected ] if next ; : expect-string ( string -- ) @@ -155,4 +155,4 @@ M: not-enough-characters summary ( obj -- str ) swap [ init-parser call ] with-input-stream ; inline : string-parse ( input quot -- ) - >r r> state-parse ; inline + [ ] dip state-parse ; inline From 90cdb6c4f4fc23b3e9c63591c3a5fcd5d22f8fa2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 8 Dec 2008 00:10:24 -0600 Subject: [PATCH 092/150] remove >r r> --- basis/memoize/memoize-tests.factor | 4 ++-- basis/nmake/nmake.factor | 2 +- basis/random/mersenne-twister/mersenne-twister-tests.factor | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/memoize/memoize-tests.factor b/basis/memoize/memoize-tests.factor index 1f819d281d..7ee56866ce 100644 --- a/basis/memoize/memoize-tests.factor +++ b/basis/memoize/memoize-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: math kernel memoize tools.test parser +USING: math kernel memoize tools.test parser generalizations prettyprint io.streams.string sequences eval ; IN: memoize.tests @@ -9,7 +9,7 @@ MEMO: fib ( m -- n ) [ 89 ] [ 10 fib ] unit-test -[ "USING: kernel math memoize ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) >r >r >r >r 1+ r> r> r> r> ;" eval ] must-fail +[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" eval ] must-fail MEMO: see-test ( a -- b ) reverse ; diff --git a/basis/nmake/nmake.factor b/basis/nmake/nmake.factor index 80c3ce3411..61a0950ce4 100644 --- a/basis/nmake/nmake.factor +++ b/basis/nmake/nmake.factor @@ -10,7 +10,7 @@ SYMBOL: building-seq : n, ( obj n -- ) get-building-seq push ; : n% ( seq n -- ) get-building-seq push-all ; -: n# ( num n -- ) >r number>string r> n% ; +: n# ( num n -- ) [ number>string ] dip n% ; : 0, ( obj -- ) 0 n, ; : 0% ( seq -- ) 0 n% ; diff --git a/basis/random/mersenne-twister/mersenne-twister-tests.factor b/basis/random/mersenne-twister/mersenne-twister-tests.factor index 8a2a5031fa..fe58e3d07c 100644 --- a/basis/random/mersenne-twister/mersenne-twister-tests.factor +++ b/basis/random/mersenne-twister/mersenne-twister-tests.factor @@ -11,7 +11,7 @@ IN: random.mersenne-twister.tests 100 [ 100 random ] replicate ; : test-rng ( seed quot -- ) - >r r> with-random ; + [ ] dip with-random ; [ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test From 22dd6a74b622488e58824c408437bcc11464c1d6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 8 Dec 2008 12:46:44 -0600 Subject: [PATCH 093/150] add a unit test for tools.files --- basis/tools/files/files-tests.factor | 3 +++ basis/tools/files/files.factor | 2 -- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/basis/tools/files/files-tests.factor b/basis/tools/files/files-tests.factor index 6aa68d8127..4dc4ef23f0 100644 --- a/basis/tools/files/files-tests.factor +++ b/basis/tools/files/files-tests.factor @@ -6,3 +6,6 @@ IN: tools.files.tests \ directory. must-infer [ ] [ "" directory. ] unit-test + +[ ] +[ { device-name free-space used-space total-space percent-used } file-systems. ] unit-test diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor index 18baedae0a..db49dcbf61 100755 --- a/basis/tools/files/files.factor +++ b/basis/tools/files/files.factor @@ -65,5 +65,3 @@ percent-used percent-free ; { [ os unix? ] [ "tools.files.unix" ] } { [ os windows? ] [ "tools.files.windows" ] } } cond require - -! { device-name free-space used-space total-space percent-used } file-systems. From f8bce9885049463dc353c8c5fcbf3dc379b8140c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Dec 2008 13:58:57 -0600 Subject: [PATCH 094/150] Remove unnecessary prettyprinter and debugger dependencies from UI --- basis/byte-vectors/byte-vectors-docs.factor | 37 ++++++++++++++ basis/byte-vectors/byte-vectors-tests.factor | 17 +++++++ basis/byte-vectors/byte-vectors.factor | 51 +++++++++++++++++++ basis/byte-vectors/summary.txt | 1 + basis/byte-vectors/tags.txt | 1 + .../streams/byte-array/byte-array-docs.factor | 34 +++++++++++++ .../byte-array/byte-array-tests.factor | 9 ++++ basis/io/streams/byte-array/byte-array.factor | 16 ++++++ basis/ui/freetype/freetype.factor | 2 +- basis/ui/gadgets/labelled/labelled.factor | 2 +- .../presentations/presentations.factor | 2 +- basis/ui/gadgets/worlds/worlds.factor | 4 +- basis/ui/ui.factor | 8 +-- basis/ui/x11/x11.factor | 2 +- 14 files changed, 176 insertions(+), 10 deletions(-) create mode 100644 basis/byte-vectors/byte-vectors-docs.factor create mode 100644 basis/byte-vectors/byte-vectors-tests.factor create mode 100644 basis/byte-vectors/byte-vectors.factor create mode 100644 basis/byte-vectors/summary.txt create mode 100644 basis/byte-vectors/tags.txt create mode 100644 basis/io/streams/byte-array/byte-array-docs.factor create mode 100644 basis/io/streams/byte-array/byte-array-tests.factor create mode 100644 basis/io/streams/byte-array/byte-array.factor diff --git a/basis/byte-vectors/byte-vectors-docs.factor b/basis/byte-vectors/byte-vectors-docs.factor new file mode 100644 index 0000000000..3873f73bfe --- /dev/null +++ b/basis/byte-vectors/byte-vectors-docs.factor @@ -0,0 +1,37 @@ +USING: arrays byte-arrays help.markup help.syntax kernel +byte-vectors.private combinators ; +IN: byte-vectors + +ARTICLE: "byte-vectors" "Byte vectors" +"A byte vector is a resizable mutable sequence of unsigned bytes. Byte vector words are found in the " { $vocab-link "byte-vectors" } " vocabulary." +$nl +"Byte vectors form a class:" +{ $subsection byte-vector } +{ $subsection byte-vector? } +"Creating byte vectors:" +{ $subsection >byte-vector } +{ $subsection } +"Literal syntax:" +{ $subsection POSTPONE: BV{ } +"If you don't care about initial capacity, a more elegant way to create a new byte vector is to write:" +{ $code "BV{ } clone" } ; + +ABOUT: "byte-vectors" + +HELP: byte-vector +{ $description "The class of resizable byte vectors. See " { $link "byte-vectors" } " for information." } ; + +HELP: +{ $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } } +{ $description "Creates a new byte vector that can hold " { $snippet "n" } " bytes before resizing." } ; + +HELP: >byte-vector +{ $values { "seq" "a sequence" } { "byte-vector" byte-vector } } +{ $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." } +{ $errors "Throws an error if the sequence contains elements other than integers." } ; + +HELP: BV{ +{ $syntax "BV{ elements... }" } +{ $values { "elements" "a list of bytes" } } +{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." } +{ $examples { $code "BV{ 1 2 3 12 }" } } ; diff --git a/basis/byte-vectors/byte-vectors-tests.factor b/basis/byte-vectors/byte-vectors-tests.factor new file mode 100644 index 0000000000..9a100d9795 --- /dev/null +++ b/basis/byte-vectors/byte-vectors-tests.factor @@ -0,0 +1,17 @@ +IN: byte-vectors.tests +USING: tools.test byte-vectors vectors sequences kernel +prettyprint ; + +[ 0 ] [ 123 length ] unit-test + +: do-it + 123 [ over push ] each ; + +[ t ] [ + 3 do-it + 3 do-it sequence= +] unit-test + +[ t ] [ BV{ } byte-vector? ] unit-test + +[ "BV{ }" ] [ BV{ } unparse ] unit-test diff --git a/basis/byte-vectors/byte-vectors.factor b/basis/byte-vectors/byte-vectors.factor new file mode 100644 index 0000000000..b2c0d55c0f --- /dev/null +++ b/basis/byte-vectors/byte-vectors.factor @@ -0,0 +1,51 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays kernel kernel.private math sequences +sequences.private growable byte-arrays accessors parser +prettyprint.backend ; +IN: byte-vectors + +TUPLE: byte-vector +{ underlying byte-array } +{ length array-capacity } ; + +: ( n -- byte-vector ) + 0 byte-vector boa ; inline + +: >byte-vector ( seq -- byte-vector ) + T{ byte-vector f B{ } 0 } clone-like ; + +M: byte-vector like + drop dup byte-vector? [ + dup byte-array? + [ dup length byte-vector boa ] [ >byte-vector ] if + ] unless ; + +M: byte-vector new-sequence + drop [ ] [ >fixnum ] bi byte-vector boa ; + +M: byte-vector equal? + over byte-vector? [ sequence= ] [ 2drop f ] if ; + +M: byte-array like + #! If we have an byte-array, we're done. + #! If we have a byte-vector, and it's at full capacity, + #! we're done. Otherwise, call resize-byte-array, which is a + #! relatively fast primitive. + drop dup byte-array? [ + dup byte-vector? [ + [ length ] [ underlying>> ] bi + 2dup length eq? + [ nip ] [ resize-byte-array ] if + ] [ >byte-array ] if + ] unless ; + +M: byte-array new-resizable drop ; + +: BV{ \ } [ >byte-vector ] parse-literal ; parsing + +M: byte-vector pprint* pprint-object ; +M: byte-vector pprint-delims drop \ BV{ \ } ; +M: byte-vector >pprint-sequence ; + +INSTANCE: byte-vector growable diff --git a/basis/byte-vectors/summary.txt b/basis/byte-vectors/summary.txt new file mode 100644 index 0000000000..e914ebb319 --- /dev/null +++ b/basis/byte-vectors/summary.txt @@ -0,0 +1 @@ +Growable byte arrays diff --git a/basis/byte-vectors/tags.txt b/basis/byte-vectors/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/basis/byte-vectors/tags.txt @@ -0,0 +1 @@ +collections diff --git a/basis/io/streams/byte-array/byte-array-docs.factor b/basis/io/streams/byte-array/byte-array-docs.factor new file mode 100644 index 0000000000..7b27621343 --- /dev/null +++ b/basis/io/streams/byte-array/byte-array-docs.factor @@ -0,0 +1,34 @@ +USING: help.syntax help.markup io byte-arrays quotations ; +IN: io.streams.byte-array + +ABOUT: "io.streams.byte-array" + +ARTICLE: "io.streams.byte-array" "Byte-array streams" +"Byte array streams:" +{ $subsection } +{ $subsection } +"Utility combinators:" +{ $subsection with-byte-reader } +{ $subsection with-byte-writer } ; + +HELP: +{ $values { "byte-array" byte-array } + { "encoding" "an encoding descriptor" } + { "stream" "a new byte reader" } } +{ $description "Creates an input stream reading from a byte array using an encoding." } ; + +HELP: +{ $values { "encoding" "an encoding descriptor" } + { "stream" "a new byte writer" } } +{ $description "Creates an output stream writing data to a byte array using an encoding." } ; + +HELP: with-byte-reader +{ $values { "encoding" "an encoding descriptor" } + { "quot" quotation } { "byte-array" byte-array } } +{ $description "Calls the quotation in a new dynamic scope with " { $link input-stream } " rebound to an input stream for reading from a byte array using an encoding." } ; + +HELP: with-byte-writer +{ $values { "encoding" "an encoding descriptor" } + { "quot" quotation } + { "byte-array" byte-array } } +{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to an output stream writing data to a byte array using an encoding." } ; diff --git a/basis/io/streams/byte-array/byte-array-tests.factor b/basis/io/streams/byte-array/byte-array-tests.factor new file mode 100644 index 0000000000..77a9126740 --- /dev/null +++ b/basis/io/streams/byte-array/byte-array-tests.factor @@ -0,0 +1,9 @@ +USING: tools.test io.streams.byte-array io.encodings.binary +io.encodings.utf8 io kernel arrays strings ; + +[ B{ 1 2 3 } ] [ binary [ { 1 2 3 } write ] with-byte-writer ] unit-test +[ B{ 1 2 3 } ] [ { 1 2 3 } binary [ 3 read ] with-byte-reader ] unit-test + +[ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ] +[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } utf8 [ write ] with-byte-writer ] unit-test +[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 contents dup >array swap string? ] unit-test diff --git a/basis/io/streams/byte-array/byte-array.factor b/basis/io/streams/byte-array/byte-array.factor new file mode 100644 index 0000000000..9d89c3d814 --- /dev/null +++ b/basis/io/streams/byte-array/byte-array.factor @@ -0,0 +1,16 @@ +USING: byte-arrays byte-vectors kernel io.encodings io.streams.string +sequences io namespaces io.encodings.private accessors ; +IN: io.streams.byte-array + +: ( encoding -- stream ) + 512 swap ; + +: with-byte-writer ( encoding quot -- byte-array ) + [ ] dip [ output-stream get ] compose with-output-stream* + dup encoder? [ stream>> ] when >byte-array ; inline + +: ( byte-array encoding -- stream ) + [ >byte-vector dup reverse-here ] dip ; + +: with-byte-reader ( byte-array encoding quot -- ) + [ ] dip with-input-stream* ; inline diff --git a/basis/ui/freetype/freetype.factor b/basis/ui/freetype/freetype.factor index 6c0eaaa9ac..22a4f1722d 100644 --- a/basis/ui/freetype/freetype.factor +++ b/basis/ui/freetype/freetype.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.accessors alien.c-types arrays io kernel libc -math math.vectors namespaces opengl opengl.gl prettyprint assocs +math math.vectors namespaces opengl opengl.gl assocs sequences io.files io.styles continuations freetype ui.gadgets.worlds ui.render ui.backend byte-arrays accessors locals specialized-arrays.direct.uchar ; diff --git a/basis/ui/gadgets/labelled/labelled.factor b/basis/ui/gadgets/labelled/labelled.factor index 108c5ae461..636e25cea5 100644 --- a/basis/ui/gadgets/labelled/labelled.factor +++ b/basis/ui/gadgets/labelled/labelled.factor @@ -3,7 +3,7 @@ USING: arrays ui.gadgets.buttons ui.gadgets.borders ui.gadgets.labels ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.theme ui.gadgets.frames -ui.gadgets.grids io kernel math models namespaces prettyprint +ui.gadgets.grids io kernel math models namespaces sequences sequences words classes.tuple ui.gadgets ui.render colors accessors ; IN: ui.gadgets.labelled diff --git a/basis/ui/gadgets/presentations/presentations.factor b/basis/ui/gadgets/presentations/presentations.factor index 33ef3bbe3a..61a55e926b 100644 --- a/basis/ui/gadgets/presentations/presentations.factor +++ b/basis/ui/gadgets/presentations/presentations.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays accessors definitions hashtables io kernel -prettyprint sequences strings io.styles words help math models +sequences strings io.styles words help math models namespaces quotations ui.gadgets ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels ui.gadgets.menus ui.gadgets.worlds diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 68a2a18210..3b9b2fa1f3 100644 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -3,7 +3,7 @@ USING: accessors arrays assocs continuations kernel math models namespaces opengl sequences io combinators fry math.vectors ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks -debugger math.geometry.rect ; +math.geometry.rect ; IN: ui.gadgets.worlds TUPLE: world < track @@ -76,7 +76,7 @@ C: world-error SYMBOL: ui-error-hook : ui-error ( error -- ) - ui-error-hook get [ call ] [ print-error ] if* ; + ui-error-hook get [ call ] [ die ] if* ; ui-error-hook global [ [ rethrow ] or ] change-at diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index de2eb71307..88f0a353b9 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs io kernel math models namespaces make -prettyprint dlists deques sequences threads sequences words -debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks -ui.gestures ui.backend ui.render continuations init combinators -hashtables concurrency.flags sets accessors calendar ; +dlists deques sequences threads sequences words ui.gadgets +ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend +ui.render continuations init combinators hashtables +concurrency.flags sets accessors calendar ; IN: ui ! Assoc mapping aliens to gadgets diff --git a/basis/ui/x11/x11.factor b/basis/ui/x11/x11.factor index b65236d1f9..a532a13b69 100755 --- a/basis/ui/x11/x11.factor +++ b/basis/ui/x11/x11.factor @@ -5,7 +5,7 @@ ui.gestures ui.backend ui.clipboards ui.gadgets.worlds ui.render assocs kernel math namespaces opengl sequences strings x11.xlib x11.events x11.xim x11.glx x11.clipboard x11.constants x11.windows io.encodings.string io.encodings.ascii -io.encodings.utf8 combinators debugger command-line qualified +io.encodings.utf8 combinators command-line qualified math.vectors classes.tuple opengl.gl threads math.geometry.rect environment ascii ; IN: ui.x11 From ca8091443cf5540d930d8f46c50a36702c682403 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Dec 2008 13:59:25 -0600 Subject: [PATCH 095/150] Move byte-vectors and io.streams.byte-array to basis --- core/byte-vectors/byte-vectors-docs.factor | 37 ---------------- core/byte-vectors/byte-vectors-tests.factor | 17 ------- core/byte-vectors/byte-vectors.factor | 44 ------------------- core/byte-vectors/summary.txt | 1 - core/byte-vectors/tags.txt | 1 - .../streams/byte-array/byte-array-docs.factor | 34 -------------- .../byte-array/byte-array-tests.factor | 9 ---- core/io/streams/byte-array/byte-array.factor | 16 ------- 8 files changed, 159 deletions(-) delete mode 100644 core/byte-vectors/byte-vectors-docs.factor delete mode 100644 core/byte-vectors/byte-vectors-tests.factor delete mode 100644 core/byte-vectors/byte-vectors.factor delete mode 100644 core/byte-vectors/summary.txt delete mode 100644 core/byte-vectors/tags.txt delete mode 100644 core/io/streams/byte-array/byte-array-docs.factor delete mode 100644 core/io/streams/byte-array/byte-array-tests.factor delete mode 100644 core/io/streams/byte-array/byte-array.factor diff --git a/core/byte-vectors/byte-vectors-docs.factor b/core/byte-vectors/byte-vectors-docs.factor deleted file mode 100644 index 3873f73bfe..0000000000 --- a/core/byte-vectors/byte-vectors-docs.factor +++ /dev/null @@ -1,37 +0,0 @@ -USING: arrays byte-arrays help.markup help.syntax kernel -byte-vectors.private combinators ; -IN: byte-vectors - -ARTICLE: "byte-vectors" "Byte vectors" -"A byte vector is a resizable mutable sequence of unsigned bytes. Byte vector words are found in the " { $vocab-link "byte-vectors" } " vocabulary." -$nl -"Byte vectors form a class:" -{ $subsection byte-vector } -{ $subsection byte-vector? } -"Creating byte vectors:" -{ $subsection >byte-vector } -{ $subsection } -"Literal syntax:" -{ $subsection POSTPONE: BV{ } -"If you don't care about initial capacity, a more elegant way to create a new byte vector is to write:" -{ $code "BV{ } clone" } ; - -ABOUT: "byte-vectors" - -HELP: byte-vector -{ $description "The class of resizable byte vectors. See " { $link "byte-vectors" } " for information." } ; - -HELP: -{ $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } } -{ $description "Creates a new byte vector that can hold " { $snippet "n" } " bytes before resizing." } ; - -HELP: >byte-vector -{ $values { "seq" "a sequence" } { "byte-vector" byte-vector } } -{ $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." } -{ $errors "Throws an error if the sequence contains elements other than integers." } ; - -HELP: BV{ -{ $syntax "BV{ elements... }" } -{ $values { "elements" "a list of bytes" } } -{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." } -{ $examples { $code "BV{ 1 2 3 12 }" } } ; diff --git a/core/byte-vectors/byte-vectors-tests.factor b/core/byte-vectors/byte-vectors-tests.factor deleted file mode 100644 index 9a100d9795..0000000000 --- a/core/byte-vectors/byte-vectors-tests.factor +++ /dev/null @@ -1,17 +0,0 @@ -IN: byte-vectors.tests -USING: tools.test byte-vectors vectors sequences kernel -prettyprint ; - -[ 0 ] [ 123 length ] unit-test - -: do-it - 123 [ over push ] each ; - -[ t ] [ - 3 do-it - 3 do-it sequence= -] unit-test - -[ t ] [ BV{ } byte-vector? ] unit-test - -[ "BV{ }" ] [ BV{ } unparse ] unit-test diff --git a/core/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor deleted file mode 100644 index 6938d02b2f..0000000000 --- a/core/byte-vectors/byte-vectors.factor +++ /dev/null @@ -1,44 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel kernel.private math sequences -sequences.private growable byte-arrays accessors ; -IN: byte-vectors - -TUPLE: byte-vector -{ underlying byte-array } -{ length array-capacity } ; - -: ( n -- byte-vector ) - 0 byte-vector boa ; inline - -: >byte-vector ( seq -- byte-vector ) - T{ byte-vector f B{ } 0 } clone-like ; - -M: byte-vector like - drop dup byte-vector? [ - dup byte-array? - [ dup length byte-vector boa ] [ >byte-vector ] if - ] unless ; - -M: byte-vector new-sequence - drop [ ] [ >fixnum ] bi byte-vector boa ; - -M: byte-vector equal? - over byte-vector? [ sequence= ] [ 2drop f ] if ; - -M: byte-array like - #! If we have an byte-array, we're done. - #! If we have a byte-vector, and it's at full capacity, - #! we're done. Otherwise, call resize-byte-array, which is a - #! relatively fast primitive. - drop dup byte-array? [ - dup byte-vector? [ - [ length ] [ underlying>> ] bi - 2dup length eq? - [ nip ] [ resize-byte-array ] if - ] [ >byte-array ] if - ] unless ; - -M: byte-array new-resizable drop ; - -INSTANCE: byte-vector growable diff --git a/core/byte-vectors/summary.txt b/core/byte-vectors/summary.txt deleted file mode 100644 index e914ebb319..0000000000 --- a/core/byte-vectors/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Growable byte arrays diff --git a/core/byte-vectors/tags.txt b/core/byte-vectors/tags.txt deleted file mode 100644 index 42d711b32b..0000000000 --- a/core/byte-vectors/tags.txt +++ /dev/null @@ -1 +0,0 @@ -collections diff --git a/core/io/streams/byte-array/byte-array-docs.factor b/core/io/streams/byte-array/byte-array-docs.factor deleted file mode 100644 index 7b27621343..0000000000 --- a/core/io/streams/byte-array/byte-array-docs.factor +++ /dev/null @@ -1,34 +0,0 @@ -USING: help.syntax help.markup io byte-arrays quotations ; -IN: io.streams.byte-array - -ABOUT: "io.streams.byte-array" - -ARTICLE: "io.streams.byte-array" "Byte-array streams" -"Byte array streams:" -{ $subsection } -{ $subsection } -"Utility combinators:" -{ $subsection with-byte-reader } -{ $subsection with-byte-writer } ; - -HELP: -{ $values { "byte-array" byte-array } - { "encoding" "an encoding descriptor" } - { "stream" "a new byte reader" } } -{ $description "Creates an input stream reading from a byte array using an encoding." } ; - -HELP: -{ $values { "encoding" "an encoding descriptor" } - { "stream" "a new byte writer" } } -{ $description "Creates an output stream writing data to a byte array using an encoding." } ; - -HELP: with-byte-reader -{ $values { "encoding" "an encoding descriptor" } - { "quot" quotation } { "byte-array" byte-array } } -{ $description "Calls the quotation in a new dynamic scope with " { $link input-stream } " rebound to an input stream for reading from a byte array using an encoding." } ; - -HELP: with-byte-writer -{ $values { "encoding" "an encoding descriptor" } - { "quot" quotation } - { "byte-array" byte-array } } -{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to an output stream writing data to a byte array using an encoding." } ; diff --git a/core/io/streams/byte-array/byte-array-tests.factor b/core/io/streams/byte-array/byte-array-tests.factor deleted file mode 100644 index 77a9126740..0000000000 --- a/core/io/streams/byte-array/byte-array-tests.factor +++ /dev/null @@ -1,9 +0,0 @@ -USING: tools.test io.streams.byte-array io.encodings.binary -io.encodings.utf8 io kernel arrays strings ; - -[ B{ 1 2 3 } ] [ binary [ { 1 2 3 } write ] with-byte-writer ] unit-test -[ B{ 1 2 3 } ] [ { 1 2 3 } binary [ 3 read ] with-byte-reader ] unit-test - -[ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ] -[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } utf8 [ write ] with-byte-writer ] unit-test -[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 contents dup >array swap string? ] unit-test diff --git a/core/io/streams/byte-array/byte-array.factor b/core/io/streams/byte-array/byte-array.factor deleted file mode 100644 index 9d89c3d814..0000000000 --- a/core/io/streams/byte-array/byte-array.factor +++ /dev/null @@ -1,16 +0,0 @@ -USING: byte-arrays byte-vectors kernel io.encodings io.streams.string -sequences io namespaces io.encodings.private accessors ; -IN: io.streams.byte-array - -: ( encoding -- stream ) - 512 swap ; - -: with-byte-writer ( encoding quot -- byte-array ) - [ ] dip [ output-stream get ] compose with-output-stream* - dup encoder? [ stream>> ] when >byte-array ; inline - -: ( byte-array encoding -- stream ) - [ >byte-vector dup reverse-here ] dip ; - -: with-byte-reader ( byte-array encoding quot -- ) - [ ] dip with-input-stream* ; inline From 73b3cd636762c72acc701d65778e0c6bee7f2153 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Dec 2008 13:59:59 -0600 Subject: [PATCH 096/150] Use eq? instead of number= since we only ever have a fixnum here --- core/math/integers/integers.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index 30903e3269..b229ea175d 100644 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -41,7 +41,7 @@ M: fixnum bitnot fixnum-bitnot ; M: fixnum bit? neg shift 1 bitand 0 > ; : fixnum-log2 ( x -- n ) - 0 swap [ dup 1 number= not ] [ [ 1+ ] [ 2/ ] bi* ] [ ] while drop ; + 0 swap [ dup 1 eq? not ] [ [ 1+ ] [ 2/ ] bi* ] [ ] while drop ; M: fixnum (log2) fixnum-log2 ; From eb4a6cbe7d514950d82f747361f7805b0f0933f6 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 8 Dec 2008 12:24:36 -0800 Subject: [PATCH 097/150] fix bunny/outlined framebuffer refresh bug and put some lipstick on it --- extra/bunny/outlined/outlined.factor | 43 ++++++++++++++++------------ 1 file changed, 25 insertions(+), 18 deletions(-) diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor index 6117a0fdea..3cf3f94d73 100755 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -1,7 +1,8 @@ USING: arrays bunny.model bunny.cel-shaded continuations destructors kernel math multiline opengl opengl.shaders -opengl.framebuffers opengl.gl opengl.demo-support -opengl.capabilities sequences ui.gadgets combinators accessors ; +opengl.framebuffers opengl.gl opengl.demo-support fry +opengl.capabilities sequences ui.gadgets combinators accessors +macros ; IN: bunny.outlined STRING: outlined-pass1-fragment-shader-main-source @@ -176,24 +177,30 @@ TUPLE: bunny-outlined } cleave ] [ drop ] if ; +MACRO: (framebuffer-texture>>draw) ( iformat xformat setter -- ) + '[ _ _ (framebuffer-texture) [ @ drop ] keep ] ; + +: (make-framebuffer-textures) ( draw dim -- draw color normal depth ) + { + [ drop ] + [ GL_RGBA16F_ARB GL_RGBA [ >>color-texture ] (framebuffer-texture>>draw) ] + [ GL_RGBA16F_ARB GL_RGBA [ >>normal-texture ] (framebuffer-texture>>draw) ] + [ + GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT + [ >>depth-texture ] (framebuffer-texture>>draw) + ] + } 2cleave ; + +: remake-framebuffer ( draw -- ) + [ dispose-framebuffer ] + [ dup gadget>> dim>> + [ (make-framebuffer-textures) (make-framebuffer) >>framebuffer ] + [ >>framebuffer-dim drop ] bi + ] bi ; + : remake-framebuffer-if-needed ( draw -- ) dup [ gadget>> dim>> ] [ framebuffer-dim>> ] bi = - [ drop ] [ - [ dispose-framebuffer ] [ dup ] [ gadget>> dim>> ] tri { - [ - GL_RGBA16F_ARB GL_RGBA (framebuffer-texture) - [ >>color-texture drop ] keep - ] [ - GL_RGBA16F_ARB GL_RGBA (framebuffer-texture) - [ >>normal-texture drop ] keep - ] [ - GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT (framebuffer-texture) - [ >>depth-texture drop ] keep - ] - } 2cleave - [ (make-framebuffer) >>framebuffer ] [ >>framebuffer-dim ] bi - drop - ] if ; + [ drop ] [ remake-framebuffer ] if ; : clear-framebuffer ( -- ) GL_COLOR_ATTACHMENT0_EXT glDrawBuffer From 9b887c7e4c9b9081feab4dfd85d461a623281065 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 8 Dec 2008 12:51:52 -0800 Subject: [PATCH 098/150] hey spheres, don't go run off the cliff if you didn't initialize --- extra/spheres/spheres.factor | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor index 7a0c0d2e77..543c26ae14 100755 --- a/extra/spheres/spheres.factor +++ b/extra/spheres/spheres.factor @@ -113,7 +113,7 @@ main() TUPLE: spheres-gadget < demo-gadget plane-program solid-sphere-program texture-sphere-program reflection-framebuffer reflection-depthbuffer - reflection-texture ; + reflection-texture initialized? ; : ( -- gadget ) 20.0 10.0 20.0 spheres-gadget new-demo-gadget ; @@ -182,9 +182,11 @@ M: spheres-gadget graft* ( gadget -- ) (make-reflection-texture) >>reflection-texture (make-reflection-depthbuffer) [ >>reflection-depthbuffer ] keep (make-reflection-framebuffer) >>reflection-framebuffer + t >>initialized? drop ; M: spheres-gadget ungraft* ( gadget -- ) + f >>initialized? dup find-gl-context { [ reflection-framebuffer>> [ delete-framebuffer ] when* ] @@ -238,9 +240,8 @@ M: spheres-gadget pref-dim* ( gadget -- dim ) ] bi ; : reflection-frustum ( gadget -- -x x -y y near far ) - [ near-plane ] [ far-plane ] bi [ - drop dup [ -+ ] bi@ - ] 2keep ; + [ near-plane ] [ far-plane ] bi + [ drop dup [ -+ ] bi@ ] 2keep ; : (reflection-face) ( gadget face -- ) swap reflection-texture>> >r >r @@ -280,7 +281,7 @@ M: spheres-gadget pref-dim* ( gadget -- dim ) [ dim>> 0 0 rot first2 glViewport ] } cleave ] with-framebuffer ; -M: spheres-gadget draw-gadget* ( gadget -- ) +: (draw-gadget) ( gadget -- ) GL_DEPTH_TEST glEnable GL_SCISSOR_TEST glDisable 0.15 0.15 1.0 1.0 glClearColor { @@ -297,6 +298,9 @@ M: spheres-gadget draw-gadget* ( gadget -- ) ] } cleave ; +M: spheres-gadget draw-gadget* ( gadget -- ) + dup initialized?>> [ (draw-gadget) ] [ drop ] if ; + : spheres-window ( -- ) [ "Spheres" open-window ] with-ui ; From 14940bd7aa946cb6790c7b88fab71be495524a15 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 8 Dec 2008 12:55:22 -0800 Subject: [PATCH 099/150] give OpenGL demo keys a little boost --- extra/opengl/demo-support/demo-support.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor index cd781508a7..92778194e3 100755 --- a/extra/opengl/demo-support/demo-support.factor +++ b/extra/opengl/demo-support/demo-support.factor @@ -5,7 +5,7 @@ IN: opengl.demo-support : FOV 2.0 sqrt 1+ ; inline : MOUSE-MOTION-SCALE 0.5 ; inline -: KEY-ROTATE-STEP 1.0 ; inline +: KEY-ROTATE-STEP 10.0 ; inline SYMBOL: last-drag-loc From 4f0a9f311e13a2007acae2f82949ec0ca500853d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Dec 2008 14:58:00 -0600 Subject: [PATCH 100/150] Untangling some dependencies --- basis/alien/prettyprint/prettyprint.factor | 14 ++++ basis/alien/syntax/syntax.factor | 12 +--- basis/bit-arrays/bit-arrays.factor | 2 +- basis/bit-vectors/bit-vectors.factor | 2 +- basis/bootstrap/bootstrap-error.factor | 8 +++ basis/bootstrap/compiler/compiler.factor | 11 ++- basis/bootstrap/finish-bootstrap.factor | 16 +++++ basis/bootstrap/finish-staging.factor | 10 +++ basis/bootstrap/math/math.factor | 4 +- basis/bootstrap/stage2.factor | 29 +++----- basis/byte-vectors/byte-vectors.factor | 2 +- basis/checksums/md5/md5.factor | 4 +- basis/checksums/openssl/openssl.factor | 5 +- basis/checksums/sha1/sha1.factor | 5 +- basis/checksums/stream/stream.factor | 12 ++++ basis/command-line/command-line.factor | 21 +----- .../alias-analysis-tests.factor | 4 +- .../cfg/dead-code/dead-code-tests.factor | 3 +- basis/compiler/cfg/debugger/debugger.factor | 20 +++++- basis/compiler/cfg/registers/registers.factor | 17 +---- .../value-numbering-tests.factor | 5 +- .../write-barrier/write-barrier-tests.factor | 3 +- basis/compiler/codegen/fixup/fixup.factor | 10 +-- basis/compiler/compiler.factor | 21 +++--- basis/compiler/tree/debugger/debugger.factor | 5 +- basis/debugger/debugger.factor | 6 +- basis/help/definitions/definitions.factor | 3 +- basis/help/lint/lint.factor | 2 +- basis/io/styles/styles.factor | 10 ++- basis/locals/locals.factor | 6 +- basis/math/complex/complex.factor | 8 +-- .../complex/prettyprint/prettyprint.factor | 8 +++ basis/nibble-arrays/nibble-arrays.factor | 2 +- basis/persistent/hashtables/hashtables.factor | 2 +- basis/persistent/vectors/vectors.factor | 2 +- basis/prettyprint/backend/backend-docs.factor | 8 +-- basis/prettyprint/backend/backend.factor | 21 ++---- basis/prettyprint/custom/custom-docs.factor | 9 +++ basis/prettyprint/custom/custom.factor | 9 +++ basis/prettyprint/prettyprint-docs.factor | 2 +- basis/prettyprint/prettyprint.factor | 15 +++-- basis/qualified/qualified.factor | 2 +- basis/regexp/regexp.factor | 10 +-- .../specialized-arrays/functor/functor.factor | 2 +- .../functor/functor.factor | 2 +- basis/stack-checker/backend/backend.factor | 12 ++-- basis/stack-checker/errors/errors.factor | 67 +------------------ .../errors/prettyprint/prettyprint.factor | 67 +++++++++++++++++++ .../known-words/known-words.factor | 2 +- basis/summary/summary.factor | 13 +--- basis/tools/deploy/backend/backend.factor | 11 ++- basis/tools/deploy/config/config-docs.factor | 29 +------- basis/tools/deploy/config/config.factor | 20 +----- .../deploy/config/editor/editor-docs.factor | 27 ++++++++ .../tools/deploy/config/editor/editor.factor | 20 ++++++ basis/tools/deploy/deploy-docs.factor | 5 ++ basis/tools/deploy/shaker/shaker.factor | 34 +++------- .../disassembler/disassembler-tests.factor | 4 +- basis/urls/urls.factor | 6 +- basis/vlists/vlists.factor | 2 +- core/bootstrap/primitives.factor | 1 - core/bootstrap/stage1.factor | 2 +- core/bootstrap/syntax.factor | 1 - core/checksums/checksums.factor | 7 +- core/classes/algebra/algebra-docs.factor | 1 + core/growable/growable-docs.factor | 2 +- core/syntax/syntax.factor | 18 +++-- 67 files changed, 386 insertions(+), 339 deletions(-) create mode 100644 basis/alien/prettyprint/prettyprint.factor create mode 100644 basis/bootstrap/bootstrap-error.factor create mode 100644 basis/bootstrap/finish-bootstrap.factor create mode 100644 basis/bootstrap/finish-staging.factor create mode 100644 basis/checksums/stream/stream.factor create mode 100644 basis/math/complex/prettyprint/prettyprint.factor create mode 100644 basis/prettyprint/custom/custom-docs.factor create mode 100644 basis/prettyprint/custom/custom.factor create mode 100644 basis/stack-checker/errors/prettyprint/prettyprint.factor create mode 100644 basis/tools/deploy/config/editor/editor-docs.factor create mode 100644 basis/tools/deploy/config/editor/editor.factor diff --git a/basis/alien/prettyprint/prettyprint.factor b/basis/alien/prettyprint/prettyprint.factor new file mode 100644 index 0000000000..0794ab7789 --- /dev/null +++ b/basis/alien/prettyprint/prettyprint.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel combinators alien alien.strings alien.syntax +prettyprint.backend prettyprint.custom prettyprint.sections ; +IN: alien.prettyprint + +M: alien pprint* + { + { [ dup expired? ] [ drop \ BAD-ALIEN pprint-word ] } + { [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] } + [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ] + } cond ; + +M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ; diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor index d10c97cd3d..b0ba10a316 100644 --- a/basis/alien/syntax/syntax.factor +++ b/basis/alien/syntax/syntax.factor @@ -3,8 +3,7 @@ USING: accessors arrays alien alien.c-types alien.structs alien.arrays alien.strings kernel math namespaces parser sequences words quotations math.parser splitting grouping -effects prettyprint prettyprint.sections prettyprint.backend -assocs combinators lexer strings.parser alien.parser ; +effects assocs combinators lexer strings.parser alien.parser ; IN: alien.syntax : DLL" lexer get skip-blank parse-string dlopen parsed ; parsing @@ -34,12 +33,3 @@ IN: alien.syntax dup length [ [ create-in ] dip 1quotation define ] 2each ; parsing - -M: alien pprint* - { - { [ dup expired? ] [ drop \ BAD-ALIEN pprint-word ] } - { [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] } - [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ] - } cond ; - -M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ; diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor index 4cb2032f4f..d5e94f0238 100644 --- a/basis/bit-arrays/bit-arrays.factor +++ b/basis/bit-arrays/bit-arrays.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types accessors math alien.accessors kernel kernel.private locals sequences sequences.private byte-arrays -parser prettyprint.backend fry ; +parser prettyprint.custom fry ; IN: bit-arrays TUPLE: bit-array diff --git a/basis/bit-vectors/bit-vectors.factor b/basis/bit-vectors/bit-vectors.factor index 404b26829b..85bea80b2d 100644 --- a/basis/bit-vectors/bit-vectors.factor +++ b/basis/bit-vectors/bit-vectors.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel kernel.private math sequences -sequences.private growable bit-arrays prettyprint.backend +sequences.private growable bit-arrays prettyprint.custom parser accessors ; IN: bit-vectors diff --git a/basis/bootstrap/bootstrap-error.factor b/basis/bootstrap/bootstrap-error.factor new file mode 100644 index 0000000000..01eb002e44 --- /dev/null +++ b/basis/bootstrap/bootstrap-error.factor @@ -0,0 +1,8 @@ +USING: continuations kernel io debugger vocabs words system namespaces ; + +:c +:error +"listener" vocab +[ restarts. vocab-main execute ] +[ die ] if* +1 exit diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index 9968af4330..f0d9e8e131 100644 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -5,17 +5,22 @@ sequences namespaces parser kernel kernel.private classes classes.private arrays hashtables vectors classes.tuple sbufs hashtables.private sequences.private math classes.tuple.private growable namespaces.private assocs words command-line vocabs io -io.encodings.string prettyprint libc splitting math.parser +io.encodings.string libc splitting math.parser compiler.units math.order compiler.tree.builder compiler.tree.optimizer compiler.cfg.optimizer ; IN: bootstrap.compiler ! Don't bring this in when deploying, since it will store a ! reference to 'eval' in a global variable -"deploy-vocab" get [ +"deploy-vocab" get "staging" get or [ "alien.remote-control" require ] unless +"prettyprint" vocab [ + "stack-checker.errors.prettyprint" require + "alien.prettyprint" require +] when + "cpu." cpu name>> append require enable-compiler @@ -86,7 +91,7 @@ nl "." write flush { - . malloc calloc free memcpy + malloc calloc free memcpy } compile-uncompiled "." write flush diff --git a/basis/bootstrap/finish-bootstrap.factor b/basis/bootstrap/finish-bootstrap.factor new file mode 100644 index 0000000000..133b64acaa --- /dev/null +++ b/basis/bootstrap/finish-bootstrap.factor @@ -0,0 +1,16 @@ +USING: init command-line debugger system continuations +namespaces eval kernel vocabs.loader io ; + +[ + boot + do-init-hooks + [ + (command-line) parse-command-line + load-vocab-roots + run-user-init + "e" get [ eval ] when* + ignore-cli-args? not script get and + [ run-script ] [ "run" get run ] if* + output-stream get [ stream-flush ] when* + ] [ print-error 1 exit ] recover +] set-boot-quot diff --git a/basis/bootstrap/finish-staging.factor b/basis/bootstrap/finish-staging.factor new file mode 100644 index 0000000000..a60ce04e15 --- /dev/null +++ b/basis/bootstrap/finish-staging.factor @@ -0,0 +1,10 @@ +USING: init command-line system namespaces kernel vocabs.loader +io ; + +[ + boot + do-init-hooks + (command-line) parse-command-line + "run" get run + output-stream get [ stream-flush ] when* +] set-boot-quot diff --git a/basis/bootstrap/math/math.factor b/basis/bootstrap/math/math.factor index a293efd33e..347969af0d 100644 --- a/basis/bootstrap/math/math.factor +++ b/basis/bootstrap/math/math.factor @@ -1,5 +1,7 @@ -USE: vocabs.loader +USING: vocabs vocabs.loader kernel ; "math.ratios" require "math.floats" require "math.complex" require + +"prettyprint" vocab [ "math.complex.prettyprint" require ] when diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index 4ab36ec94e..78355a4670 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -2,10 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors init namespaces words io kernel.private math memory continuations kernel io.files -io.backend system parser vocabs sequences prettyprint +io.backend system parser vocabs sequences vocabs.loader combinators splitting source-files strings definitions assocs compiler.errors compiler.units -math.parser generic sets debugger command-line ; +math.parser generic sets command-line ; IN: bootstrap.stage2 SYMBOL: core-bootstrap-time @@ -86,25 +86,18 @@ SYMBOL: bootstrap-time f error set-global f error-continuation set-global + millis swap - bootstrap-time set-global + print-report + "deploy-vocab" get [ "tools.deploy.shaker" run ] [ - [ - boot - do-init-hooks - handle-command-line - ] set-boot-quot - - millis swap - bootstrap-time set-global - print-report + "staging" get [ + "resource:basis/bootstrap/finish-staging.factor" run-file + ] [ + "resource:basis/bootstrap/finish-bootstrap.factor" run-file + ] if "output-image" get save-image-and-exit ] if -] [ - :c - dup print-error flush - "listener" vocab - [ restarts. vocab-main execute ] - [ die ] if* - 1 exit -] recover +] [ drop "resource:basis/bootstrap/bootstrap-error.factor" run-file ] recover diff --git a/basis/byte-vectors/byte-vectors.factor b/basis/byte-vectors/byte-vectors.factor index b2c0d55c0f..e24c808bbc 100644 --- a/basis/byte-vectors/byte-vectors.factor +++ b/basis/byte-vectors/byte-vectors.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel kernel.private math sequences sequences.private growable byte-arrays accessors parser -prettyprint.backend ; +prettyprint.custom ; IN: byte-vectors TUPLE: byte-vector diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor index 257fd930c4..d919b0e313 100644 --- a/basis/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -4,7 +4,7 @@ USING: kernel io io.binary io.files io.streams.byte-array math math.functions math.parser namespaces splitting grouping strings sequences byte-arrays locals sequences.private io.encodings.binary symbols math.bitwise checksums -checksums.common ; +checksums.common checksums.stream ; IN: checksums.md5 ! See http://www.faqs.org/rfcs/rfc1321.html @@ -180,7 +180,7 @@ PRIVATE> SINGLETON: md5 -INSTANCE: md5 checksum +INSTANCE: md5 stream-checksum M: md5 checksum-stream ( stream -- byte-array ) drop [ initialize-md5 stream>md5 get-md5 ] with-input-stream ; diff --git a/basis/checksums/openssl/openssl.factor b/basis/checksums/openssl/openssl.factor index 821cbe2f3a..4bc7a7964a 100644 --- a/basis/checksums/openssl/openssl.factor +++ b/basis/checksums/openssl/openssl.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors byte-arrays alien.c-types kernel continuations -destructors sequences io openssl openssl.libcrypto checksums ; +destructors sequences io openssl openssl.libcrypto checksums +checksums.stream ; IN: checksums.openssl ERROR: unknown-digest name ; @@ -12,7 +13,7 @@ TUPLE: openssl-checksum name ; : openssl-sha1 T{ openssl-checksum f "sha1" } ; -INSTANCE: openssl-checksum checksum +INSTANCE: openssl-checksum stream-checksum C: openssl-checksum diff --git a/basis/checksums/sha1/sha1.factor b/basis/checksums/sha1/sha1.factor index 3767af7c55..6cdc9270aa 100644 --- a/basis/checksums/sha1/sha1.factor +++ b/basis/checksums/sha1/sha1.factor @@ -3,7 +3,8 @@ USING: arrays combinators kernel io io.encodings.binary io.files io.streams.byte-array math.vectors strings sequences namespaces make math parser sequences assocs grouping vectors io.binary -hashtables symbols math.bitwise checksums checksums.common ; +hashtables symbols math.bitwise checksums checksums.common +checksums.stream ; IN: checksums.sha1 ! Implemented according to RFC 3174. @@ -113,7 +114,7 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ; SINGLETON: sha1 -INSTANCE: sha1 checksum +INSTANCE: sha1 stream-checksum M: sha1 checksum-stream ( stream -- sha1 ) drop [ initialize-sha1 stream>sha1 get-sha1 ] with-input-stream ; diff --git a/basis/checksums/stream/stream.factor b/basis/checksums/stream/stream.factor new file mode 100644 index 0000000000..e753467323 --- /dev/null +++ b/basis/checksums/stream/stream.factor @@ -0,0 +1,12 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings.binary io.streams.byte-array kernel +checksums ; +IN: checksums.stream + +MIXIN: stream-checksum + +M: stream-checksum checksum-bytes + [ binary ] dip checksum-stream ; + +INSTANCE: stream-checksum checksum diff --git a/basis/command-line/command-line.factor b/basis/command-line/command-line.factor index 1b58053b64..7d5a041951 100644 --- a/basis/command-line/command-line.factor +++ b/basis/command-line/command-line.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: init continuations debugger hashtables io -io.encodings.utf8 io.files kernel kernel.private namespaces -parser sequences strings system splitting eval vocabs.loader ; +USING: init continuations hashtables io io.encodings.utf8 +io.files kernel kernel.private namespaces parser sequences +strings system splitting vocabs.loader ; IN: command-line SYMBOL: script @@ -31,8 +31,6 @@ SYMBOL: command-line ] [ drop ] if ] when ; - - : parse-command-line ( args -- ) [ command-line off script off ] [ unclip "-" ?head @@ -76,15 +72,4 @@ SYMBOL: main-vocab-hook : script-mode ( -- ) ; -: handle-command-line ( -- ) - [ - (command-line) parse-command-line - load-vocab-roots - run-user-init - "e" get [ eval ] when* - ignore-cli-args? not script get and - [ run-script ] [ "run" get run ] if* - output-stream get [ stream-flush ] when* - ] [ print-error 1 exit ] recover ; - [ default-cli-args ] "command-line" add-init-hook diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor index c7094c8c36..d8bad5ec41 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor @@ -1,6 +1,6 @@ USING: compiler.cfg.instructions compiler.cfg.registers -compiler.cfg.alias-analysis cpu.architecture tools.test -kernel ; +compiler.cfg.alias-analysis compiler.cfg.debugger +cpu.architecture tools.test kernel ; IN: compiler.cfg.alias-analysis.tests [ ] [ diff --git a/basis/compiler/cfg/dead-code/dead-code-tests.factor b/basis/compiler/cfg/dead-code/dead-code-tests.factor index b9c3af5215..ee7d8d2a43 100644 --- a/basis/compiler/cfg/dead-code/dead-code-tests.factor +++ b/basis/compiler/cfg/dead-code/dead-code-tests.factor @@ -1,5 +1,6 @@ USING: compiler.cfg.dead-code compiler.cfg.instructions -compiler.cfg.registers cpu.architecture tools.test ; +compiler.cfg.registers compiler.cfg.debugger +cpu.architecture tools.test ; IN: compiler.cfg.dead-code.tests [ { } ] [ diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor index 7b1b9100c4..ba58e60a4a 100644 --- a/basis/compiler/cfg/debugger/debugger.factor +++ b/basis/compiler/cfg/debugger/debugger.factor @@ -2,10 +2,12 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel words sequences quotations namespaces io classes.tuple accessors prettyprint prettyprint.config -compiler.tree.builder compiler.tree.optimizer +prettyprint.backend prettyprint.custom prettyprint.sections +parser compiler.tree.builder compiler.tree.optimizer compiler.cfg.builder compiler.cfg.linearization -compiler.cfg.stack-frame compiler.cfg.linear-scan -compiler.cfg.two-operand compiler.cfg.optimizer ; +compiler.cfg.registers compiler.cfg.stack-frame +compiler.cfg.linear-scan compiler.cfg.two-operand +compiler.cfg.optimizer ; IN: compiler.cfg.debugger GENERIC: test-cfg ( quot -- cfgs ) @@ -40,3 +42,15 @@ SYMBOL: allocate-registers? instructions>> [ insn. ] each nl ] each ; + +! Prettyprinting +M: vreg pprint* + > pprint* ] [ n>> pprint* ] bi + block> ; + +: pprint-loc ( loc word -- ) > pprint* block> ; + +M: ds-loc pprint* \ D pprint-loc ; + +M: rs-loc pprint* \ R pprint-loc ; diff --git a/basis/compiler/cfg/registers/registers.factor b/basis/compiler/cfg/registers/registers.factor index 21572ec615..2b9d3df6f6 100644 --- a/basis/compiler/cfg/registers/registers.factor +++ b/basis/compiler/cfg/registers/registers.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors namespaces kernel arrays -parser prettyprint.backend prettyprint.sections ; +USING: accessors namespaces kernel arrays parser ; IN: compiler.cfg.registers ! Virtual registers, used by CFG and machine IRs @@ -18,20 +17,6 @@ C: ds-loc TUPLE: rs-loc < loc ; C: rs-loc -! Prettyprinting : V scan-word scan-word vreg boa parsed ; parsing - -M: vreg pprint* - > pprint* ] [ n>> pprint* ] bi - block> ; - -: pprint-loc ( loc word -- ) > pprint* block> ; - : D scan-word parsed ; parsing - -M: ds-loc pprint* \ D pprint-loc ; - : R scan-word parsed ; parsing - -M: rs-loc pprint* \ R pprint-loc ; diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor index 8adeaa21f4..641ccceb5d 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -1,7 +1,8 @@ IN: compiler.cfg.value-numbering.tests USING: compiler.cfg.value-numbering compiler.cfg.instructions -compiler.cfg.registers cpu.architecture tools.test kernel math -combinators.short-circuit accessors sequences ; +compiler.cfg.registers compiler.cfg.debugger cpu.architecture +tools.test kernel math combinators.short-circuit accessors +sequences ; : trim-temps ( insns -- insns ) [ diff --git a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor index 7a4b1c488f..73748dbc37 100644 --- a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor +++ b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor @@ -1,5 +1,6 @@ USING: compiler.cfg.write-barrier compiler.cfg.instructions -compiler.cfg.registers cpu.architecture arrays tools.test ; +compiler.cfg.registers compiler.cfg.debugger cpu.architecture +arrays tools.test ; IN: compiler.cfg.write-barrier.tests [ diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor index a56ae04a7b..e0f391deb5 100755 --- a/basis/compiler/codegen/fixup/fixup.factor +++ b/basis/compiler/codegen/fixup/fixup.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays byte-arrays generic assocs hashtables io.binary -kernel kernel.private math namespaces make sequences words -quotations strings alien.accessors alien.strings layouts system -combinators math.bitwise words.private math.order accessors -growable cpu.architecture compiler.constants ; +USING: arrays byte-arrays byte-vectors generic assocs hashtables +io.binary kernel kernel.private math namespaces make sequences +words quotations strings alien.accessors alien.strings layouts +system combinators math.bitwise words.private math.order +accessors growable cpu.architecture compiler.constants ; IN: compiler.codegen.fixup GENERIC: fixup* ( obj -- ) diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index e5cbd888d9..0d24daef71 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -1,15 +1,14 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel namespaces arrays sequences io debugger -words fry continuations vocabs assocs dlists definitions -math threads graphs generic combinators deques search-deques -prettyprint io stack-checker stack-checker.state -stack-checker.inlining compiler.errors compiler.units -compiler.tree.builder compiler.tree.optimizer -compiler.cfg.builder compiler.cfg.optimizer -compiler.cfg.linearization compiler.cfg.two-operand -compiler.cfg.linear-scan compiler.cfg.stack-frame -compiler.codegen ; +USING: accessors kernel namespaces arrays sequences io +words fry continuations vocabs assocs dlists definitions math +threads graphs generic combinators deques search-deques io +stack-checker stack-checker.state stack-checker.inlining +compiler.errors compiler.units compiler.tree.builder +compiler.tree.optimizer compiler.cfg.builder +compiler.cfg.optimizer compiler.cfg.linearization +compiler.cfg.two-operand compiler.cfg.linear-scan +compiler.cfg.stack-frame compiler.codegen ; IN: compiler SYMBOL: compile-queue @@ -45,7 +44,7 @@ SYMBOL: +failed+ 2bi ; : start ( word -- ) - "trace-compilation" get [ dup . flush ] when + "trace-compilation" get [ dup name>> print flush ] when H{ } clone dependencies set H{ } clone generic-dependencies set f swap compiler-error ; diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index 8d764a2833..8a2823010d 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -2,8 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel assocs match fry accessors namespaces make effects sequences sequences.private quotations generic macros arrays -prettyprint prettyprint.backend prettyprint.sections math words -combinators combinators.short-circuit io sorting hints qualified +prettyprint prettyprint.backend prettyprint.custom +prettyprint.sections math words combinators +combinators.short-circuit io sorting hints qualified compiler.tree compiler.tree.recursive compiler.tree.normalization diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 35b09713d3..4e0c4e8840 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -22,9 +22,6 @@ M: tuple error-help class ; M: string error. print ; -: :error ( -- ) - error get error. ; - : :s ( -- ) error-continuation get data>> stack. ; @@ -63,6 +60,9 @@ M: string error. print ; [ global [ "Error in print-error!" print drop ] bind ] recover ; +: :error ( -- ) + error get print-error ; + : print-error-and-restarts ( error -- ) print-error restarts. diff --git a/basis/help/definitions/definitions.factor b/basis/help/definitions/definitions.factor index e5202e1306..3e4066d8b7 100644 --- a/basis/help/definitions/definitions.factor +++ b/basis/help/definitions/definitions.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors definitions help help.topics help.syntax -prettyprint.backend prettyprint words kernel effects ; +prettyprint.backend prettyprint.custom prettyprint words kernel +effects ; IN: help.definitions ! Definition protocol implementation diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index 0a392733ac..fbebc7f0f6 100644 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -150,7 +150,7 @@ M: help-error error. ] [ [ swap vocab-heading. - [ error. nl ] each + [ print-error nl ] each ] assoc-each ] if-empty ; diff --git a/basis/io/styles/styles.factor b/basis/io/styles/styles.factor index c9ba8f66df..e07753c640 100644 --- a/basis/io/styles/styles.factor +++ b/basis/io/styles/styles.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: hashtables io colors ; +USING: hashtables io colors summary make accessors splitting +kernel ; IN: io.styles SYMBOL: plain @@ -43,4 +44,11 @@ TUPLE: input string ; C: input +M: input summary + [ + "Input: " % + string>> "\n" split1 swap % + "..." "" ? % + ] "" make ; + : write-object ( str obj -- ) presented associate format ; diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index b78b95bc24..80bafb0b55 100644 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces make sequences sequences.private assocs math vectors strings classes.tuple generalizations parser words -quotations debugger macros arrays macros splitting combinators -prettyprint.backend definitions prettyprint hashtables -prettyprint.sections sets sequences.private effects +quotations macros arrays macros splitting combinators +prettyprint.backend prettyprint.custom definitions prettyprint +hashtables prettyprint.sections sets sequences.private effects effects.parser generic generic.parser compiler.units accessors locals.backend memoize macros.expander lexer classes summary fry fry.private ; diff --git a/basis/math/complex/complex.factor b/basis/math/complex/complex.factor index c228684e32..90713cd40f 100644 --- a/basis/math/complex/complex.factor +++ b/basis/math/complex/complex.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel kernel.private math math.private -math.libm math.functions prettyprint.backend arrays -math.functions.private sequences parser ; +math.libm math.functions arrays math.functions.private sequences +parser ; IN: math.complex.private M: real real-part ; @@ -47,7 +47,3 @@ M: complex sqrt >polar [ fsqrt ] [ 2.0 / ] bi* polar> ; IN: syntax : C{ \ } [ first2 rect> ] parse-literal ; parsing - -M: complex pprint-delims drop \ C{ \ } ; -M: complex >pprint-sequence >rect 2array ; -M: complex pprint* pprint-object ; diff --git a/basis/math/complex/prettyprint/prettyprint.factor b/basis/math/complex/prettyprint/prettyprint.factor new file mode 100644 index 0000000000..09eeb8045c --- /dev/null +++ b/basis/math/complex/prettyprint/prettyprint.factor @@ -0,0 +1,8 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: math math.functions arrays prettyprint.custom kernel ; +IN: math.complex.prettyprint + +M: complex pprint* pprint-object ; +M: complex pprint-delims drop \ C{ \ } ; +M: complex >pprint-sequence >rect 2array ; diff --git a/basis/nibble-arrays/nibble-arrays.factor b/basis/nibble-arrays/nibble-arrays.factor index c753d0fb78..82643bef15 100644 --- a/basis/nibble-arrays/nibble-arrays.factor +++ b/basis/nibble-arrays/nibble-arrays.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: math kernel sequences sequences.private byte-arrays -alien.c-types prettyprint.backend parser accessors ; +alien.c-types prettyprint.custom parser accessors ; IN: nibble-arrays TUPLE: nibble-array diff --git a/basis/persistent/hashtables/hashtables.factor b/basis/persistent/hashtables/hashtables.factor index e50fd52c10..8c80782a2e 100644 --- a/basis/persistent/hashtables/hashtables.factor +++ b/basis/persistent/hashtables/hashtables.factor @@ -1,7 +1,7 @@ ! Based on Clojure's PersistentHashMap by Rich Hickey. USING: kernel math accessors assocs fry combinators parser -prettyprint.backend make +prettyprint.custom make persistent.assocs persistent.hashtables.nodes persistent.hashtables.nodes.empty diff --git a/basis/persistent/vectors/vectors.factor b/basis/persistent/vectors/vectors.factor index 92b3f82a54..cd8e7c49e0 100644 --- a/basis/persistent/vectors/vectors.factor +++ b/basis/persistent/vectors/vectors.factor @@ -1,7 +1,7 @@ ! Based on Clojure's PersistentVector by Rich Hickey. USING: math accessors kernel sequences.private sequences arrays -combinators combinators.short-circuit parser prettyprint.backend +combinators combinators.short-circuit parser prettyprint.custom persistent.sequences ; IN: persistent.vectors diff --git a/basis/prettyprint/backend/backend-docs.factor b/basis/prettyprint/backend/backend-docs.factor index 64e1fd45ff..165621887f 100644 --- a/basis/prettyprint/backend/backend-docs.factor +++ b/basis/prettyprint/backend/backend-docs.factor @@ -1,14 +1,10 @@ USING: help.markup help.syntax io kernel -prettyprint.config prettyprint.sections words strings ; +prettyprint.config prettyprint.sections prettyprint.custom +words strings ; IN: prettyprint.backend ABOUT: "prettyprint-extension" -HELP: pprint* -{ $values { "obj" "an object" } } -{ $contract "Adds sections to the current block corresponding to the prettyprinted representation of the object." } -$prettyprinting-note ; - HELP: pprint-word { $values { "word" "a word" } } { $description "Adds a text section for the word. Unlike the " { $link word } " method of " { $link pprint* } ", this does not add a " { $link POSTPONE: POSTPONE: } " prefix to parsing words." } diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index 76c3918f63..92d039a15d 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -1,15 +1,13 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays byte-arrays byte-vectors generic -hashtables io assocs kernel math namespaces make sequences -strings sbufs io.styles vectors words prettyprint.config +USING: accessors arrays byte-arrays generic hashtables io assocs +kernel math namespaces make sequences strings sbufs io.styles +vectors words prettyprint.config prettyprint.custom prettyprint.sections quotations io io.files math.parser effects classes.tuple math.order classes.tuple.private classes combinators colors ; IN: prettyprint.backend -GENERIC: pprint* ( obj -- ) - M: effect pprint* effect>string "(" ")" surround text ; : ?effect-height ( word -- n ) @@ -161,26 +159,19 @@ M: tuple pprint* [ [ pprint* ] each ] dip [ "~" swap number>string " more~" 3append text ] when* ; -GENERIC: pprint-delims ( obj -- start end ) - M: quotation pprint-delims drop \ [ \ ] ; M: curry pprint-delims drop \ [ \ ] ; M: compose pprint-delims drop \ [ \ ] ; M: array pprint-delims drop \ { \ } ; M: byte-array pprint-delims drop \ B{ \ } ; -M: byte-vector pprint-delims drop \ BV{ \ } ; M: vector pprint-delims drop \ V{ \ } ; M: hashtable pprint-delims drop \ H{ \ } ; M: tuple pprint-delims drop \ T{ \ } ; M: wrapper pprint-delims drop \ W{ \ } ; M: callstack pprint-delims drop \ CS{ \ } ; -GENERIC: >pprint-sequence ( obj -- seq ) - M: object >pprint-sequence ; - M: vector >pprint-sequence ; -M: byte-vector >pprint-sequence ; M: curry >pprint-sequence ; M: compose >pprint-sequence ; M: hashtable >pprint-sequence >alist ; @@ -191,16 +182,13 @@ M: tuple >pprint-sequence [ class ] [ tuple-slots ] bi [ 1array ] [ [ f 2array ] dip append ] if-empty ; -GENERIC: pprint-narrow? ( obj -- ? ) - M: object pprint-narrow? drop f ; - M: array pprint-narrow? drop t ; M: vector pprint-narrow? drop t ; M: hashtable pprint-narrow? drop t ; M: tuple pprint-narrow? drop t ; -: pprint-object ( obj -- ) +M: object pprint-object ( obj -- ) [ pprint-sequence ( obj -- seq ) +GENERIC: pprint-narrow? ( obj -- ? ) diff --git a/basis/prettyprint/prettyprint-docs.factor b/basis/prettyprint/prettyprint-docs.factor index 3c004e5b30..46d4e6e5ff 100644 --- a/basis/prettyprint/prettyprint-docs.factor +++ b/basis/prettyprint/prettyprint-docs.factor @@ -1,4 +1,4 @@ -USING: prettyprint.backend prettyprint.config +USING: prettyprint.backend prettyprint.config prettyprint.custom prettyprint.sections prettyprint.private help.markup help.syntax io kernel words definitions quotations strings generic classes ; IN: prettyprint diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor index 7c4de1e973..9d5af9e6a5 100644 --- a/basis/prettyprint/prettyprint.factor +++ b/basis/prettyprint/prettyprint.factor @@ -2,12 +2,13 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic generic.standard assocs io kernel math namespaces make sequences strings io.styles io.streams.string -vectors words prettyprint.backend prettyprint.sections -prettyprint.config sorting splitting grouping math.parser vocabs -definitions effects classes.builtin classes.tuple io.files -classes continuations hashtables classes.mixin classes.union -classes.intersection classes.predicate classes.singleton -combinators quotations sets accessors colors parser ; +vectors words prettyprint.backend prettyprint.custom +prettyprint.sections prettyprint.config sorting splitting +grouping math.parser vocabs definitions effects classes.builtin +classes.tuple io.files classes continuations hashtables +classes.mixin classes.union classes.intersection +classes.predicate classes.singleton combinators quotations sets +accessors colors parser summary ; IN: prettyprint : make-pprint ( obj quot -- block in use ) @@ -231,6 +232,8 @@ M: pathname synopsis* pprint* ; [ synopsis* ] with-in ] with-string-writer ; +M: word summary synopsis ; + : synopsis-alist ( definitions -- alist ) [ dup synopsis swap ] { } map>assoc ; diff --git a/basis/qualified/qualified.factor b/basis/qualified/qualified.factor index 25d04ed929..2cd64e90bf 100644 --- a/basis/qualified/qualified.factor +++ b/basis/qualified/qualified.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences assocs hashtables parser lexer -vocabs words namespaces vocabs.loader debugger sets fry ; +vocabs words namespaces vocabs.loader sets fry ; IN: qualified : define-qualified ( vocab-name prefix-name -- ) diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index b41e4d271e..c615719cc4 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors combinators kernel math sequences strings -sets assocs prettyprint.backend make lexer namespaces parser -arrays fry regexp.backend regexp.utils regexp.parser regexp.nfa -regexp.dfa regexp.traversal regexp.transition-tables splitting -sorting ; +USING: accessors combinators kernel math sequences strings sets +assocs prettyprint.backend prettyprint.custom make lexer +namespaces parser arrays fry regexp.backend regexp.utils +regexp.parser regexp.nfa regexp.dfa regexp.traversal +regexp.transition-tables splitting sorting ; IN: regexp : default-regexp ( string -- regexp ) diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor index 52977dc22a..2894649428 100644 --- a/basis/specialized-arrays/functor/functor.factor +++ b/basis/specialized-arrays/functor/functor.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: functors sequences sequences.private prettyprint.backend +USING: functors sequences sequences.private prettyprint.custom kernel words classes math parser alien.c-types byte-arrays accessors summary ; IN: specialized-arrays.functor diff --git a/basis/specialized-vectors/functor/functor.factor b/basis/specialized-vectors/functor/functor.factor index 0628f8b484..8ba5354dc4 100644 --- a/basis/specialized-vectors/functor/functor.factor +++ b/basis/specialized-vectors/functor/functor.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: functors sequences sequences.private growable -prettyprint.backend kernel words classes math parser ; +prettyprint.custom kernel words classes math parser ; IN: specialized-vectors.functor FUNCTOR: define-vector ( T -- ) diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 7f8c920b19..147749864d 100644 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry arrays generic io io.streams.string kernel math -namespaces parser prettyprint sequences strings vectors words -quotations effects classes continuations debugger assocs -combinators compiler.errors accessors math.order definitions -sets generic.standard.engines.tuple hints stack-checker.state -stack-checker.visitor stack-checker.errors -stack-checker.values stack-checker.recursive-state ; +namespaces parser sequences strings vectors words quotations +effects classes continuations assocs combinators +compiler.errors accessors math.order definitions sets +generic.standard.engines.tuple hints stack-checker.state +stack-checker.visitor stack-checker.errors stack-checker.values +stack-checker.recursive-state ; IN: stack-checker.backend : push-d ( obj -- ) meta-d push ; diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index 5b6b3c0893..58944e7bc4 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel generic sequences prettyprint io words arrays -summary effects debugger assocs accessors namespaces -compiler.errors stack-checker.values +USING: kernel generic sequences io words arrays summary effects +assocs accessors namespaces compiler.errors stack-checker.values stack-checker.recursive-state ; IN: stack-checker.errors @@ -10,8 +9,6 @@ TUPLE: inference-error error type word ; M: inference-error compiler-error-type type>> ; -M: inference-error error-help error>> error-help ; - : (inference-error) ( ... class type -- * ) [ boa ] dip recursive-state get word>> @@ -23,14 +20,8 @@ M: inference-error error-help error>> error-help ; : inference-warning ( ... class -- * ) +warning+ (inference-error) ; inline -M: inference-error error. - [ word>> [ "In word: " write . ] when* ] [ error>> error. ] bi ; - TUPLE: literal-expected ; -M: literal-expected summary - drop "Literal value expected" ; - M: object (literal) \ literal-expected inference-warning ; TUPLE: unbalanced-branches-error branches quots ; @@ -38,79 +29,25 @@ TUPLE: unbalanced-branches-error branches quots ; : unbalanced-branches-error ( branches quots -- * ) \ unbalanced-branches-error inference-error ; -M: unbalanced-branches-error error. - "Unbalanced branches:" print - [ quots>> ] [ branches>> [ length ] { } assoc>map ] bi zip - [ [ first pprint-short bl ] [ second effect>string print ] bi ] each ; - TUPLE: too-many->r ; -M: too-many->r summary - drop - "Quotation pushes elements on retain stack without popping them" ; - TUPLE: too-many-r> ; -M: too-many-r> summary - drop - "Quotation pops retain stack elements which it did not push" ; - TUPLE: missing-effect word ; -M: missing-effect error. - "The word " write - word>> pprint - " must declare a stack effect" print ; - TUPLE: effect-error word inferred declared ; : effect-error ( word inferred declared -- * ) \ effect-error inference-error ; -M: effect-error error. - "Stack effects of the word " write - [ word>> pprint " do not match." print ] - [ "Inferred: " write inferred>> . ] - [ "Declared: " write declared>> . ] tri ; - TUPLE: recursive-quotation-error quot ; -M: recursive-quotation-error error. - "The quotation " write - quot>> pprint - " calls itself." print - "Stack effect inference is undecidable when quotation-level recursion is permitted." print ; - TUPLE: undeclared-recursion-error word ; -M: undeclared-recursion-error error. - "The inline recursive word " write - word>> pprint - " must be declared recursive" print ; - TUPLE: diverging-recursion-error word ; -M: diverging-recursion-error error. - "The recursive word " write - word>> pprint - " digs arbitrarily deep into the stack" print ; - TUPLE: unbalanced-recursion-error word height ; -M: unbalanced-recursion-error error. - "The recursive word " write - word>> pprint - " leaves with the stack having the wrong height" print ; - TUPLE: inconsistent-recursive-call-error word ; -M: inconsistent-recursive-call-error error. - "The recursive word " write - word>> pprint - " calls itself with a different set of quotation parameters than were input" print ; - TUPLE: unknown-primitive-error ; - -M: unknown-primitive-error error. - drop - "Cannot determine stack effect statically" print ; diff --git a/basis/stack-checker/errors/prettyprint/prettyprint.factor b/basis/stack-checker/errors/prettyprint/prettyprint.factor new file mode 100644 index 0000000000..21c6d64402 --- /dev/null +++ b/basis/stack-checker/errors/prettyprint/prettyprint.factor @@ -0,0 +1,67 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel prettyprint io debugger +sequences assocs stack-checker.errors summary effects ; +IN: stack-checker.errors.prettyprint + +M: inference-error error-help error>> error-help ; + +M: inference-error error. + [ word>> [ "In word: " write . ] when* ] [ error>> error. ] bi ; + +M: literal-expected summary + drop "Literal value expected" ; + +M: unbalanced-branches-error error. + "Unbalanced branches:" print + [ quots>> ] [ branches>> [ length ] { } assoc>map ] bi zip + [ [ first pprint-short bl ] [ second effect>string print ] bi ] each ; + +M: too-many->r summary + drop + "Quotation pushes elements on retain stack without popping them" ; + +M: too-many-r> summary + drop + "Quotation pops retain stack elements which it did not push" ; + +M: missing-effect error. + "The word " write + word>> pprint + " must declare a stack effect" print ; + +M: effect-error error. + "Stack effects of the word " write + [ word>> pprint " do not match." print ] + [ "Inferred: " write inferred>> . ] + [ "Declared: " write declared>> . ] tri ; + +M: recursive-quotation-error error. + "The quotation " write + quot>> pprint + " calls itself." print + "Stack effect inference is undecidable when quotation-level recursion is permitted." print ; + +M: undeclared-recursion-error error. + "The inline recursive word " write + word>> pprint + " must be declared recursive" print ; + +M: diverging-recursion-error error. + "The recursive word " write + word>> pprint + " digs arbitrarily deep into the stack" print ; + +M: unbalanced-recursion-error error. + "The recursive word " write + word>> pprint + " leaves with the stack having the wrong height" print ; + +M: inconsistent-recursive-call-error error. + "The recursive word " write + word>> pprint + " calls itself with a different set of quotation parameters than were input" print ; + +M: unknown-primitive-error error. + drop + "Cannot determine stack effect statically" print ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 28634f2d44..0442d4c227 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -5,7 +5,7 @@ classes sequences.private continuations.private effects generic hashtables hashtables.private io io.backend io.files io.files.private io.streams.c kernel kernel.private math math.private memory namespaces namespaces.private parser -prettyprint quotations quotations.private sbufs sbufs.private +quotations quotations.private sbufs sbufs.private sequences sequences.private slots.private strings strings.private system threads.private classes.tuple classes.tuple.private vectors vectors.private words definitions diff --git a/basis/summary/summary.factor b/basis/summary/summary.factor index ea2c19fd6d..44e5374dc5 100644 --- a/basis/summary/summary.factor +++ b/basis/summary/summary.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors classes sequences splitting kernel namespaces -make words math math.parser io.styles prettyprint assocs ; +USING: accessors classes sequences kernel namespaces +make words math math.parser assocs ; IN: summary GENERIC: summary ( object -- string ) @@ -11,15 +11,6 @@ GENERIC: summary ( object -- string ) M: object summary object-summary ; -M: input summary - [ - "Input: " % - string>> "\n" split1 swap % - "..." "" ? % - ] "" make ; - -M: word summary synopsis ; - M: sequence summary [ dup class name>> % diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor index 18713c7b0c..f33e4840eb 100644 --- a/basis/tools/deploy/backend/backend.factor +++ b/basis/tools/deploy/backend/backend.factor @@ -5,8 +5,8 @@ assocs kernel vocabs words sequences memory io system arrays continuations math definitions mirrors splitting parser classes summary layouts vocabs.loader prettyprint.config prettyprint debugger io.streams.c io.files io.backend quotations io.launcher -words.private tools.deploy.config bootstrap.image -io.encodings.utf8 destructors accessors ; +words.private tools.deploy.config tools.deploy.config.editor +bootstrap.image io.encodings.utf8 destructors accessors ; IN: tools.deploy.backend : copy-vm ( executable bundle-name extension -- vm ) @@ -88,6 +88,10 @@ DEFER: ?make-staging-image dup staging-image-name exists? [ drop ] [ make-staging-image ] if ; +: make-deploy-config ( vocab -- file ) + [ deploy-config unparse-use ] [ "deploy-config-" prepend ] bi + [ utf8 set-file-contents ] keep ; + : deploy-command-line ( image vocab config -- flags ) [ bootstrap-profile ?make-staging-image @@ -99,7 +103,8 @@ DEFER: ?make-staging-image "-run=tools.deploy.shaker" , - "-deploy-vocab=" prepend , + [ "-deploy-vocab=" prepend , ] + [ make-deploy-config "-deploy-config=" prepend , ] bi "-output-image=" prepend , diff --git a/basis/tools/deploy/config/config-docs.factor b/basis/tools/deploy/config/config-docs.factor index e8dcd2b90e..c8249e4e41 100644 --- a/basis/tools/deploy/config/config-docs.factor +++ b/basis/tools/deploy/config/config-docs.factor @@ -2,16 +2,6 @@ USING: help.markup help.syntax words alien.c-types assocs kernel math ; IN: tools.deploy.config -ARTICLE: "deploy-config" "Deployment configuration" -"The deployment configuration is a key/value mapping stored in the " { $snippet "deploy.factor" } " file in the vocabulary's directory. If this file does not exist, the default deployment configuration is used:" -{ $subsection default-config } -"The deployment configuration can be read and written with a pair of words:" -{ $subsection deploy-config } -{ $subsection set-deploy-config } -"A utility word is provided to load the configuration, change a flag, and store it back to disk:" -{ $subsection set-deploy-flag } -"The " { $link "ui.tools.deploy" } " provides a graphical way of editing the configuration." ; - ARTICLE: "deploy-flags" "Deployment flags" "There are two sets of deployment flags. The first set controls the major subsystems which are to be included in the deployment image:" { $subsection deploy-math? } @@ -25,12 +15,7 @@ ARTICLE: "deploy-flags" "Deployment flags" { $subsection deploy-word-props? } { $subsection deploy-c-types? } ; -ARTICLE: "prepare-deploy" "Preparing to deploy an application" -"In order to deploy an application as a stand-alone image, the application's vocabulary must first be given a " { $link POSTPONE: MAIN: } " hook. Then, a " { $emphasis "deployment configuration" } " must be created." -{ $subsection "deploy-config" } -{ $subsection "deploy-flags" } ; - -ABOUT: "prepare-deploy" +ABOUT: "deploy-flags" HELP: deploy-name { $description "Deploy setting. The name of the executable." @@ -114,15 +99,3 @@ HELP: deploy-reflection HELP: default-config { $values { "vocab" "a vocabulary specifier" } { "assoc" assoc } } { $description "Outputs the default deployment configuration for a vocabulary." } ; - -HELP: deploy-config -{ $values { "vocab" "a vocabulary specifier" } { "assoc" assoc } } -{ $description "Loads a vocabulary's deployment configuration from the " { $snippet "deploy.factor" } " file in the vocabulary's directory. If the file does not exist, the " { $link default-config } " is output." } ; - -HELP: set-deploy-config -{ $values { "assoc" assoc } { "vocab" "a vocabulary specifier" } } -{ $description "Stores a vocabulary's deployment configuration to the " { $snippet "deploy.factor" } " file in the vocabulary's directory." } ; - -HELP: set-deploy-flag -{ $values { "value" object } { "key" object } { "vocab" "a vocabulary specifier" } } -{ $description "Modifies an entry in a vocabulary's deployment configuration on disk." } ; diff --git a/basis/tools/deploy/config/config.factor b/basis/tools/deploy/config/config.factor index 84bfab682b..1d9761e885 100644 --- a/basis/tools/deploy/config/config.factor +++ b/basis/tools/deploy/config/config.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: vocabs.loader io.files io kernel sequences assocs -splitting parser prettyprint namespaces math vocabs -hashtables tools.vocabs ; +USING: io.files io kernel sequences assocs splitting parser +namespaces math vocabs hashtables ; IN: tools.deploy.config SYMBOL: deploy-name @@ -66,18 +65,3 @@ SYMBOL: deploy-image ! default value for deploy.macosx { "stop-after-last-window?" t } } assoc-union ; - -: deploy-config-path ( vocab -- string ) - vocab-dir "deploy.factor" append-path ; - -: deploy-config ( vocab -- assoc ) - dup default-config swap - dup deploy-config-path vocab-file-contents - parse-fresh [ first assoc-union ] unless-empty ; - -: set-deploy-config ( assoc vocab -- ) - [ unparse-use string-lines ] dip - dup deploy-config-path set-vocab-file-contents ; - -: set-deploy-flag ( value key vocab -- ) - [ deploy-config [ set-at ] keep ] keep set-deploy-config ; diff --git a/basis/tools/deploy/config/editor/editor-docs.factor b/basis/tools/deploy/config/editor/editor-docs.factor new file mode 100644 index 0000000000..b677d37f95 --- /dev/null +++ b/basis/tools/deploy/config/editor/editor-docs.factor @@ -0,0 +1,27 @@ +USING: assocs help.markup help.syntax kernel +tools.deploy.config ; +IN: tools.deploy.config.editor + +ARTICLE: "deploy-config" "Deployment configuration" +"The deployment configuration is a key/value mapping stored in the " { $snippet "deploy.factor" } " file in the vocabulary's directory. If this file does not exist, the default deployment configuration is used:" +{ $subsection default-config } +"The deployment configuration can be read and written with a pair of words:" +{ $subsection deploy-config } +{ $subsection set-deploy-config } +"A utility word is provided to load the configuration, change a flag, and store it back to disk:" +{ $subsection set-deploy-flag } +"The " { $link "ui.tools.deploy" } " provides a graphical way of editing the configuration." ; + +HELP: deploy-config +{ $values { "vocab" "a vocabulary specifier" } { "assoc" assoc } } +{ $description "Loads a vocabulary's deployment configuration from the " { $snippet "deploy.factor" } " file in the vocabulary's directory. If the file does not exist, the " { $link default-config } " is output." } ; + +HELP: set-deploy-config +{ $values { "assoc" assoc } { "vocab" "a vocabulary specifier" } } +{ $description "Stores a vocabulary's deployment configuration to the " { $snippet "deploy.factor" } " file in the vocabulary's directory." } ; + +HELP: set-deploy-flag +{ $values { "value" object } { "key" object } { "vocab" "a vocabulary specifier" } } +{ $description "Modifies an entry in a vocabulary's deployment configuration on disk." } ; + +ABOUT: "deploy-config" diff --git a/basis/tools/deploy/config/editor/editor.factor b/basis/tools/deploy/config/editor/editor.factor new file mode 100644 index 0000000000..2b5788adfc --- /dev/null +++ b/basis/tools/deploy/config/editor/editor.factor @@ -0,0 +1,20 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs io.files kernel parser prettyprint sequences +splitting tools.deploy.config tools.vocabs vocabs.loader ; +IN: tools.deploy.config.editor + +: deploy-config-path ( vocab -- string ) + vocab-dir "deploy.factor" append-path ; + +: deploy-config ( vocab -- assoc ) + dup default-config swap + dup deploy-config-path vocab-file-contents + parse-fresh [ first assoc-union ] unless-empty ; + +: set-deploy-config ( assoc vocab -- ) + [ unparse-use string-lines ] dip + dup deploy-config-path set-vocab-file-contents ; + +: set-deploy-flag ( value key vocab -- ) + [ deploy-config [ set-at ] keep ] keep set-deploy-config ; diff --git a/basis/tools/deploy/deploy-docs.factor b/basis/tools/deploy/deploy-docs.factor index eccb3982c7..00e747cf00 100644 --- a/basis/tools/deploy/deploy-docs.factor +++ b/basis/tools/deploy/deploy-docs.factor @@ -2,6 +2,11 @@ USING: help.markup help.syntax words alien.c-types assocs kernel ; IN: tools.deploy +ARTICLE: "prepare-deploy" "Preparing to deploy an application" +"In order to deploy an application as a stand-alone image, the application's vocabulary must first be given a " { $link POSTPONE: MAIN: } " hook. Then, a " { $emphasis "deployment configuration" } " must be created." +{ $subsection "deploy-config" } +{ $subsection "deploy-flags" } ; + ARTICLE: "tools.deploy" "Application deployment" "The stand-alone application deployment tool compiles a vocabulary down to a native executable which runs the vocabulary's " { $link POSTPONE: MAIN: } " hook. Deployed executables do not depend on Factor being installed, and do not expose any source code, and thus are suitable for delivering commercial end-user applications." $nl diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 15fd2a37d7..01cc80e90d 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors qualified io.backend io.streams.c init fry -namespaces make assocs kernel parser lexer strings.parser -tools.deploy.config vocabs sequences words words.private memory -kernel.private continuations io prettyprint vocabs.loader -debugger system strings sets vectors quotations byte-arrays -sorting compiler.units definitions generic generic.standard ; +namespaces make assocs kernel parser lexer strings.parser vocabs +sequences words words.private memory kernel.private +continuations io vocabs.loader system strings sets +vectors quotations byte-arrays sorting compiler.units +definitions generic generic.standard tools.deploy.config ; QUALIFIED: bootstrap.stage2 QUALIFIED: classes QUALIFIED: command-line @@ -14,7 +14,6 @@ QUALIFIED: continuations QUALIFIED: definitions QUALIFIED: init QUALIFIED: layouts -QUALIFIED: prettyprint.config QUALIFIED: source-files QUALIFIED: vocabs IN: tools.deploy.shaker @@ -41,7 +40,7 @@ IN: tools.deploy.shaker ] when ; : strip-debugger ( -- ) - strip-debugger? [ + strip-debugger? "debugger" vocab and [ "Stripping debugger" show "resource:basis/tools/deploy/shaker/strip-debugger.factor" run-file @@ -81,14 +80,11 @@ IN: tools.deploy.shaker >alist f like ] change-props drop ] each - ] [ - "Remaining word properties:\n" show - [ props>> keys ] gather unparse show ] [ H{ } clone '[ [ [ _ [ ] cache ] map ] change-props drop ] each - ] tri ; + ] bi ; : stripped-word-props ( -- seq ) [ @@ -275,12 +271,7 @@ IN: tools.deploy.shaker ] when strip-prettyprint? [ - { - prettyprint.config:margin - prettyprint.config:string-limit? - prettyprint.config:boa-tuples? - prettyprint.config:tab-size - } % + { } { "prettyprint.config" } strip-vocab-globals % ] when strip-debugger? [ @@ -308,7 +299,6 @@ IN: tools.deploy.shaker '[ drop _ member? not ] assoc-filter [ drop string? not ] assoc-filter ! strip CLI args sift-assoc - dup keys unparse show 21 setenv ] [ drop ] if ; @@ -362,7 +352,7 @@ SYMBOL: deploy-vocab init-hooks get values concat % , strip-io? [ \ flush , ] unless - ] [ ] make "Boot quotation: " show dup unparse show + ] [ ] make set-boot-quot ; : init-stripper ( -- ) @@ -405,16 +395,14 @@ SYMBOL: deploy-vocab deploy-vocab get require strip finish-deploy - ] [ - print-error flush 1 exit - ] recover + ] [ die 1 exit ] recover ] bind ; : do-deploy ( -- ) "output-image" get "deploy-vocab" get "Deploying " write dup write "..." print - dup deploy-config dup . + "deploy-config" get parse-file first (deploy) ; MAIN: do-deploy diff --git a/basis/tools/disassembler/disassembler-tests.factor b/basis/tools/disassembler/disassembler-tests.factor index 782f244c68..96f5a04378 100644 --- a/basis/tools/disassembler/disassembler-tests.factor +++ b/basis/tools/disassembler/disassembler-tests.factor @@ -1,6 +1,6 @@ IN: tools.disassembler.tests -USING: math classes.tuple prettyprint.backend tools.disassembler -tools.test strings ; +USING: math classes.tuple prettyprint.custom +tools.disassembler tools.test strings ; [ ] [ \ + disassemble ] unit-test [ ] [ { string pprint* } disassemble ] unit-test diff --git a/basis/urls/urls.factor b/basis/urls/urls.factor index c0fb1695c3..5f6d04a54f 100644 --- a/basis/urls/urls.factor +++ b/basis/urls/urls.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel ascii combinators combinators.short-circuit sequences splitting fry namespaces make assocs arrays strings -io.sockets io.encodings.string -io.encodings.utf8 math math.parser accessors parser -strings.parser lexer prettyprint.backend hashtables present +io.sockets io.encodings.string io.encodings.utf8 math +math.parser accessors parser strings.parser lexer +prettyprint.backend prettyprint.custom hashtables present peg.ebnf urls.encoding ; IN: urls diff --git a/basis/vlists/vlists.factor b/basis/vlists/vlists.factor index e0f7e55554..ea40594964 100644 --- a/basis/vlists/vlists.factor +++ b/basis/vlists/vlists.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays accessors sequences sequences.private persistent.sequences assocs persistent.assocs kernel math -vectors parser prettyprint.backend ; +vectors parser prettyprint.custom ; IN: vlists TUPLE: vlist diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index f90ba23999..42e1de19ee 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -68,7 +68,6 @@ bootstrapping? on "alien.accessors" "arrays" "byte-arrays" - "byte-vectors" "classes.private" "classes.tuple" "classes.tuple.private" diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 26a27ecefb..874a9dd0d2 100644 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -31,7 +31,7 @@ load-help? off "math.integers" require "math.floats" require "memory" require - + "io.streams.c" require "vocabs.loader" require diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index e7dd333ed8..badc1f5218 100644 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -16,7 +16,6 @@ IN: bootstrap.syntax " ] dip checksum-stream ; - M: checksum checksum-stream [ contents ] dip checksum-bytes ; diff --git a/core/classes/algebra/algebra-docs.factor b/core/classes/algebra/algebra-docs.factor index 810bdbe10f..2730e4683b 100644 --- a/core/classes/algebra/algebra-docs.factor +++ b/core/classes/algebra/algebra-docs.factor @@ -4,6 +4,7 @@ IN: classes.algebra ARTICLE: "class-operations" "Class operations" "Set-theoretic operations on classes:" +{ $subsection class= } { $subsection class< } { $subsection class<= } { $subsection class-and } diff --git a/core/growable/growable-docs.factor b/core/growable/growable-docs.factor index 9f950aa36c..e1ab50cdcd 100644 --- a/core/growable/growable-docs.factor +++ b/core/growable/growable-docs.factor @@ -14,7 +14,7 @@ $nl } "The underlying sequence must implement a generic word:" { $subsection resize } -{ $link "vectors" } ", " { $link "byte-vectors" } " and " { $link "sbufs" } " are implemented using the resizable sequence facility." ; +{ $link "vectors" } " and " { $link "sbufs" } " are implemented using the resizable sequence facility." ; ABOUT: "growable" diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index c951750b34..0b7d9d008f 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -1,14 +1,13 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien arrays byte-arrays byte-vectors -definitions generic hashtables kernel math namespaces parser -lexer sequences strings strings.parser sbufs vectors -words quotations io assocs splitting classes.tuple -generic.standard generic.math generic.parser classes io.files -vocabs classes.parser classes.union -classes.intersection classes.mixin classes.predicate -classes.singleton classes.tuple.parser compiler.units -combinators effects.parser slots ; +USING: accessors alien arrays byte-arrays definitions generic +hashtables kernel math namespaces parser lexer sequences strings +strings.parser sbufs vectors words quotations io assocs +splitting classes.tuple generic.standard generic.math +generic.parser classes io.files vocabs classes.parser +classes.union classes.intersection classes.mixin +classes.predicate classes.singleton classes.tuple.parser +compiler.units combinators effects.parser slots ; IN: bootstrap.syntax ! These words are defined as a top-level form, instead of with @@ -81,7 +80,6 @@ IN: bootstrap.syntax "{" [ \ } [ >array ] parse-literal ] define-syntax "V{" [ \ } [ >vector ] parse-literal ] define-syntax "B{" [ \ } [ >byte-array ] parse-literal ] define-syntax - "BV{" [ \ } [ >byte-vector ] parse-literal ] define-syntax "H{" [ \ } [ >hashtable ] parse-literal ] define-syntax "T{" [ parse-tuple-literal parsed ] define-syntax "W{" [ \ } [ first ] parse-literal ] define-syntax From 6edb771d05ec2626b53196816d419451f93b82d6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Dec 2008 16:01:11 -0600 Subject: [PATCH 101/150] Re-arrange some code so that core-foundation.run-loop no longer depends on calendar --- basis/core-foundation/run-loop/run-loop.factor | 11 +---------- basis/core-foundation/run-loop/thread/thread.factor | 10 +++++++++- 2 files changed, 10 insertions(+), 11 deletions(-) diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor index c334297122..39f4101301 100644 --- a/basis/core-foundation/run-loop/run-loop.factor +++ b/basis/core-foundation/run-loop/run-loop.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax kernel threads init namespaces alien -core-foundation calendar ; +USING: alien alien.syntax core-foundation kernel namespaces ; IN: core-foundation.run-loop : kCFRunLoopRunFinished 1 ; inline @@ -40,11 +39,3 @@ FUNCTION: void CFRunLoopAddSource ( "kCFRunLoopDefaultMode" dup \ CFRunLoopDefaultMode set-global ] when ; - -: run-loop-thread ( -- ) - CFRunLoopDefaultMode 0 f CFRunLoopRunInMode - kCFRunLoopRunHandledSource = [ 1 seconds sleep ] unless - run-loop-thread ; - -: start-run-loop-thread ( -- ) - [ run-loop-thread t ] "CFRunLoop dispatcher" spawn-server drop ; diff --git a/basis/core-foundation/run-loop/thread/thread.factor b/basis/core-foundation/run-loop/thread/thread.factor index 326226ec0e..aeeff312cb 100644 --- a/basis/core-foundation/run-loop/thread/thread.factor +++ b/basis/core-foundation/run-loop/thread/thread.factor @@ -1,8 +1,16 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: init core-foundation.run-loop ; +USING: calendar core-foundation.run-loop init kernel threads ; IN: core-foundation.run-loop.thread ! Load this vocabulary if you need a run loop running. +: run-loop-thread ( -- ) + CFRunLoopDefaultMode 0 f CFRunLoopRunInMode + kCFRunLoopRunHandledSource = [ 1 seconds sleep ] unless + run-loop-thread ; + +: start-run-loop-thread ( -- ) + [ run-loop-thread t ] "CFRunLoop dispatcher" spawn-server drop ; + [ start-run-loop-thread ] "core-foundation.run-loop.thread" add-init-hook From ba6f63ff56a6bc5bfa2150a599384f155c3b106e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Dec 2008 16:02:10 -0600 Subject: [PATCH 102/150] calendar.format now depends on present instead of the other way around --- basis/calendar/format/format.factor | 11 +++++++---- basis/present/present.factor | 5 +---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor index 8d34e8a3a4..a7c4410aa5 100644 --- a/basis/calendar/format/format.factor +++ b/basis/calendar/format/format.factor @@ -1,7 +1,8 @@ -USING: math math.order math.parser math.functions kernel sequences io -accessors arrays io.streams.string splitting -combinators accessors debugger -calendar calendar.format.macros ; +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: math math.order math.parser math.functions kernel +sequences io accessors arrays io.streams.string splitting +combinators accessors calendar calendar.format.macros present ; IN: calendar.format : pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-left ; @@ -288,3 +289,5 @@ ERROR: invalid-timestamp-format ; ] } formatted ] with-string-writer ; + +M: timestamp present timestamp>string ; diff --git a/basis/present/present.factor b/basis/present/present.factor index 519e995fe5..fe7025d559 100644 --- a/basis/present/present.factor +++ b/basis/present/present.factor @@ -1,15 +1,12 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors math math.parser calendar calendar.format -strings words kernel effects ; +USING: accessors math math.parser strings words kernel effects ; IN: present GENERIC: present ( object -- string ) M: real present number>string ; -M: timestamp present timestamp>string ; - M: string present ; M: word present name>> ; From 7940020491f4bc1afa86ab9c14c3d339e5c13dbe Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Dec 2008 16:02:31 -0600 Subject: [PATCH 103/150] Untangling more dependencies --- basis/alarms/alarms.factor | 2 +- basis/bootstrap/threads/threads.factor | 6 +++- basis/cocoa/application/application.factor | 6 ++-- basis/cocoa/messages/messages.factor | 36 ++++--------------- basis/functors/functors.factor | 10 +++--- basis/help/handbook/handbook.factor | 4 +-- .../known-words/known-words.factor | 2 +- basis/tools/cocoa/cocoa.factor | 16 +++++++++ basis/tools/cocoa/tags.txt | 1 + basis/tools/deploy/backend/backend.factor | 3 +- basis/tools/deploy/deploy-tests.factor | 4 +++ basis/tools/deploy/macosx/macosx.factor | 11 +++--- basis/tools/deploy/shaker/strip-cocoa.factor | 5 --- basis/ui/cocoa/cocoa.factor | 11 +++--- basis/ui/tools/deploy/deploy.factor | 10 +++--- basis/unix/debugger/debugger.factor | 18 ++++++++++ basis/unix/unix.factor | 22 ++++-------- core/source-files/source-files.factor | 2 +- 18 files changed, 90 insertions(+), 79 deletions(-) create mode 100644 basis/tools/cocoa/cocoa.factor create mode 100644 basis/tools/cocoa/tags.txt create mode 100644 basis/unix/debugger/debugger.factor diff --git a/basis/alarms/alarms.factor b/basis/alarms/alarms.factor index ad1838b3df..9cc05b4159 100644 --- a/basis/alarms/alarms.factor +++ b/basis/alarms/alarms.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays calendar combinators generic init -kernel math namespaces sequences heaps boxes threads debugger +kernel math namespaces sequences heaps boxes threads quotations assocs math.order ; IN: alarms diff --git a/basis/bootstrap/threads/threads.factor b/basis/bootstrap/threads/threads.factor index 6c30489bb4..8b751f8458 100644 --- a/basis/bootstrap/threads/threads.factor +++ b/basis/bootstrap/threads/threads.factor @@ -1,7 +1,11 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: vocabs vocabs.loader kernel ; IN: bootstrap.threads USE: io.thread USE: threads -USE: debugger.threads + +"debugger" vocab [ + "debugger.threads" require +] when diff --git a/basis/cocoa/application/application.factor b/basis/cocoa/application/application.factor index ab12a93a31..e2c853ea77 100644 --- a/basis/cocoa/application/application.factor +++ b/basis/cocoa/application/application.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2006, 2007 Slava Pestov +! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.syntax io kernel namespaces core-foundation core-foundation.run-loop cocoa.messages cocoa cocoa.classes -cocoa.runtime sequences threads debugger init summary -kernel.private assocs ; +cocoa.runtime sequences threads init summary kernel.private +assocs ; IN: cocoa.application : ( str -- alien ) -> autorelease ; diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index e33217a691..5f548bdeb8 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -2,21 +2,17 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types alien.strings arrays assocs continuations combinators compiler compiler.alien kernel math -namespaces make parser prettyprint prettyprint.sections -quotations sequences strings words cocoa.runtime io macros -memoize debugger io.encodings.ascii effects libc libc.private -parser lexer init core-foundation fry generalizations -specialized-arrays.direct.alien ; +namespaces make parser quotations sequences strings words +cocoa.runtime io macros memoize io.encodings.ascii +effects libc libc.private parser lexer init core-foundation fry +generalizations specialized-arrays.direct.alien ; IN: cocoa.messages : make-sender ( method function -- quot ) [ over first , f , , second , \ alien-invoke , ] [ ] make ; -: sender-stub-name ( method function -- string ) - [ % "_" % unparse % ] "" make ; - : sender-stub ( method function -- word ) - [ sender-stub-name f dup ] 2keep + [ "( sender-stub )" f dup ] 2dip over first large-struct? [ "_stret" append ] when make-sender define ; @@ -78,12 +74,8 @@ MACRO: (send) ( selector super? -- quot ) : send ( receiver args... selector -- return... ) f (send) ; inline -\ send soft "break-after" set-word-prop - : super-send ( receiver args... selector -- return... ) t (send) ; inline -\ super-send soft "break-after" set-word-prop - ! Runtime introspection SYMBOL: class-init-hooks @@ -216,17 +208,6 @@ assoc-union alien>objc-types set-global : register-objc-methods ( class -- ) [ register-objc-method ] each-method-in-class ; -: method. ( method -- ) - { - [ method_getName sel_getName ] - [ method-return-type ] - [ method-arg-types ] - [ method_getImplementation ] - } cleave 4array . ; - -: methods. ( class -- ) - [ method. ] each-method-in-class ; - : class-exists? ( string -- class ) objc_getClass >boolean ; : define-objc-class-word ( quot name -- ) @@ -238,11 +219,8 @@ assoc-union alien>objc-types set-global : import-objc-class ( name quot -- ) over define-objc-class-word - '[ - _ - [ objc-class register-objc-methods ] - [ objc-meta-class register-objc-methods ] bi - ] try ; + [ objc-class register-objc-methods ] + [ objc-meta-class register-objc-methods ] bi ; : root-class ( class -- root ) dup class_getSuperclass [ root-class ] [ ] ?if ; diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index 7126806c3d..7dab80c22d 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel locals.private quotations classes.tuple make -combinators generic words interpolate namespaces sequences -io.streams.string fry classes.mixin effects lexer parser -classes.tuple.parser effects.parser ; +USING: kernel quotations classes.tuple make combinators generic +words interpolate namespaces sequences io.streams.string fry +classes.mixin effects lexer parser classes.tuple.parser +effects.parser locals.types locals.parser locals.rewrite.closures ; IN: functors : scan-param ( -- obj ) @@ -101,6 +101,6 @@ DEFER: ;FUNCTOR delimiter CREATE parse-locals parse-functor-body swap pop-locals - lambda-rewrite first ; + rewrite-closures first ; : FUNCTOR: (FUNCTOR:) define ; parsing diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index 2ed86a0a19..cc36e9faab 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -1,7 +1,7 @@ USING: help help.markup help.syntax help.definitions help.topics namespaces words sequences classes assocs vocabs kernel arrays -prettyprint.backend kernel.private io generic math system -strings sbufs vectors byte-arrays quotations +prettyprint.backend prettyprint.custom kernel.private io generic +math system strings sbufs vectors byte-arrays quotations io.streams.byte-array classes.builtin parser lexer classes.predicate classes.union classes.intersection classes.singleton classes.tuple tools.vocabs.browser math.parser diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 0442d4c227..a998e5394b 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -10,7 +10,7 @@ sequences sequences.private slots.private strings strings.private system threads.private classes.tuple classes.tuple.private vectors vectors.private words definitions words.private assocs summary compiler.units system.private -combinators locals locals.backend locals.private words.private +combinators locals locals.backend locals.types words.private quotations.private stack-checker.values stack-checker.alien stack-checker.state diff --git a/basis/tools/cocoa/cocoa.factor b/basis/tools/cocoa/cocoa.factor new file mode 100644 index 0000000000..a8cdf6f41c --- /dev/null +++ b/basis/tools/cocoa/cocoa.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays cocoa.messages cocoa.runtime combinators +prettyprint ; +IN: tools.cocoa + +: method. ( method -- ) + { + [ method_getName sel_getName ] + [ method-return-type ] + [ method-arg-types ] + [ method_getImplementation ] + } cleave 4array . ; + +: methods. ( class -- ) + [ method. ] each-method-in-class ; diff --git a/basis/tools/cocoa/tags.txt b/basis/tools/cocoa/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/tools/cocoa/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor index f33e4840eb..ee8615ac5a 100644 --- a/basis/tools/deploy/backend/backend.factor +++ b/basis/tools/deploy/backend/backend.factor @@ -89,7 +89,8 @@ DEFER: ?make-staging-image [ drop ] [ make-staging-image ] if ; : make-deploy-config ( vocab -- file ) - [ deploy-config unparse-use ] [ "deploy-config-" prepend ] bi + [ deploy-config unparse-use ] + [ "deploy-config-" prepend temp-file ] bi [ utf8 set-file-contents ] keep ; : deploy-command-line ( image vocab config -- flags ) diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index 9cc48972fa..af065c9bf6 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -31,6 +31,10 @@ urls math.parser ; [ t ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test +os macosx? [ + [ t ] [ "webkit-demo" shake-and-bake 500000 small-enough? ] unit-test +] when + : run-temp-image ( -- ) vm "-i=" "test.image" temp-file append diff --git a/basis/tools/deploy/macosx/macosx.factor b/basis/tools/deploy/macosx/macosx.factor index d3464993e1..1f0e482441 100644 --- a/basis/tools/deploy/macosx/macosx.factor +++ b/basis/tools/deploy/macosx/macosx.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.files kernel namespaces make sequences -system tools.deploy.backend tools.deploy.config assocs -hashtables prettyprint io.unix.backend cocoa io.encodings.utf8 -io.backend cocoa.application cocoa.classes cocoa.plists -qualified combinators ; +USING: io io.files kernel namespaces make sequences system +tools.deploy.backend tools.deploy.config +tools.deploy.config.editor assocs hashtables prettyprint +io.unix.backend cocoa io.encodings.utf8 io.backend +cocoa.application cocoa.classes cocoa.plists qualified +combinators ; IN: tools.deploy.macosx : bundle-dir ( -- dir ) diff --git a/basis/tools/deploy/shaker/strip-cocoa.factor b/basis/tools/deploy/shaker/strip-cocoa.factor index d5249dc20c..773b2d0f3b 100644 --- a/basis/tools/deploy/shaker/strip-cocoa.factor +++ b/basis/tools/deploy/shaker/strip-cocoa.factor @@ -25,11 +25,6 @@ H{ } clone \ pool [ global [ "stop-after-last-window?" "ui" lookup set - "ui.cocoa" vocab [ - [ "MiniFactor.nib" load-nib ] - "cocoa-init-hook" "ui.cocoa" lookup set-global - ] when - ! Only keeps those methods that we actually call sent-messages get super-sent-messages get assoc-union objc-methods [ assoc-intersect pool-values ] change diff --git a/basis/ui/cocoa/cocoa.factor b/basis/ui/cocoa/cocoa.factor index 42063fbf73..b90f4d34fe 100644 --- a/basis/ui/cocoa/cocoa.factor +++ b/basis/ui/cocoa/cocoa.factor @@ -3,9 +3,10 @@ USING: accessors math arrays assocs cocoa cocoa.application command-line kernel memory namespaces cocoa.messages cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types -cocoa.windows cocoa.classes cocoa.application sequences system -ui ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds -ui.cocoa.views core-foundation threads math.geometry.rect fry ; +cocoa.windows cocoa.classes cocoa.application cocoa.nibs +sequences system ui ui.backend ui.clipboards ui.gadgets +ui.gadgets.worlds ui.cocoa.views core-foundation threads +math.geometry.rect fry ; IN: ui.cocoa TUPLE: handle view window ; @@ -110,7 +111,9 @@ CLASS: { SYMBOL: cocoa-init-hook -cocoa-init-hook global [ [ install-app-delegate ] or ] change-at +cocoa-init-hook global [ + [ "MiniFactor.nib" load-nib install-app-delegate ] or +] change-at M: cocoa-ui-backend ui "UI" assert.app [ diff --git a/basis/ui/tools/deploy/deploy.factor b/basis/ui/tools/deploy/deploy.factor index f023b0959a..f233c9f162 100644 --- a/basis/ui/tools/deploy/deploy.factor +++ b/basis/ui/tools/deploy/deploy.factor @@ -1,11 +1,11 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: ui.gadgets colors kernel ui.render namespaces models models.mapping sequences ui.gadgets.buttons ui.gadgets.packs -ui.gadgets.labels tools.deploy.config namespaces -ui.gadgets.editors ui.gadgets.borders ui.gestures ui.commands -assocs ui.gadgets.tracks ui ui.tools.listener tools.deploy -vocabs ui.tools.workspace system accessors fry ; +ui.gadgets.labels tools.deploy.config tools.deploy.config.editor +namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures +ui.commands assocs ui.gadgets.tracks ui ui.tools.listener +tools.deploy vocabs ui.tools.workspace system accessors fry ; IN: ui.tools.deploy TUPLE: deploy-gadget < pack vocab settings ; diff --git a/basis/unix/debugger/debugger.factor b/basis/unix/debugger/debugger.factor new file mode 100644 index 0000000000..713c2202d4 --- /dev/null +++ b/basis/unix/debugger/debugger.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: debugger prettyprint accessors io ; +IN: unix.debugger + +M: unix-error error. + "Unix system call failed:" print + nl + dup message>> write " (" write errno>> pprint ")" print ; + +M: unix-system-call-error error. + "Unix system call ``" write dup word>> pprint "'' failed:" print + nl + dup message>> write " (" write dup errno>> pprint ")" print + nl + "It was called with the following arguments:" print + nl + args>> stack. ; diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index d917425bf9..555f8e2c7d 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax kernel libc sequences continuations byte-arrays strings math namespaces system combinators vocabs.loader qualified accessors stack-checker macros locals generalizations unix.types -debugger io prettyprint io.files ; +io io.files vocabs vocabs.loader ; IN: unix : PROT_NONE 0 ; inline @@ -60,26 +60,12 @@ FUNCTION: char* strerror ( int errno ) ; ERROR: unix-error errno message ; -M: unix-error error. - "Unix system call failed:" print - nl - dup message>> write " (" write errno>> pprint ")" print ; - : (io-error) ( -- * ) err_no dup strerror unix-error ; : io-error ( n -- ) 0 < [ (io-error) ] when ; ERROR: unix-system-call-error args errno message word ; -M: unix-system-call-error error. - "Unix system call ``" write dup word>> pprint "'' failed:" print - nl - dup message>> write " (" write dup errno>> pprint ")" print - nl - "It was called with the following arguments:" print - nl - args>> stack. ; - MACRO:: unix-system-call ( quot -- ) [let | n [ quot infer in>> ] word [ quot first ] | @@ -236,3 +222,7 @@ FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ; { [ os bsd? ] [ "unix.bsd" require ] } { [ os solaris? ] [ "unix.solaris" require ] } } cond + +"debugger" vocab [ + "unix.debugger" require +] when diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 767c2a1f79..3ae50a9a15 100644 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -78,7 +78,7 @@ M: pathname forget* SYMBOL: file -TUPLE: source-file-error file error ; +TUPLE: source-file-error error file ; : ( msg -- error ) \ source-file-error new From 403ae9db9e8fa95477aa40560624d5bab118fb4a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Dec 2008 18:48:35 -0600 Subject: [PATCH 104/150] Fix load error in unix.debugger --- basis/unix/debugger/debugger.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/unix/debugger/debugger.factor b/basis/unix/debugger/debugger.factor index 713c2202d4..ea32657057 100644 --- a/basis/unix/debugger/debugger.factor +++ b/basis/unix/debugger/debugger.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: debugger prettyprint accessors io ; +USING: debugger prettyprint accessors unix io kernel ; IN: unix.debugger M: unix-error error. From ac653d5c31dac37133b5752873e2a0d0e3e2e5bc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Dec 2008 18:48:49 -0600 Subject: [PATCH 105/150] Core foundation now uses UTF8 instead of UTF16, to eliminate unnecessary dependency --- .../core-foundation-tests.factor | 9 +++ basis/core-foundation/core-foundation.factor | 58 +++++++++++++++++-- 2 files changed, 61 insertions(+), 6 deletions(-) create mode 100644 basis/core-foundation/core-foundation-tests.factor diff --git a/basis/core-foundation/core-foundation-tests.factor b/basis/core-foundation/core-foundation-tests.factor new file mode 100644 index 0000000000..c1d6788d50 --- /dev/null +++ b/basis/core-foundation/core-foundation-tests.factor @@ -0,0 +1,9 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: core-foundation tools.test kernel ; +IN: core-foundation + +[ ] [ "Hello" CFRelease ] unit-test +[ "Hello" ] [ "Hello" [ CF>string ] [ CFRelease ] bi ] unit-test +[ "Hello\u003456" ] [ "Hello\u003456" [ CF>string ] [ CFRelease ] bi ] unit-test +[ "Hello\u013456" ] [ "Hello\u013456" [ CF>string ] [ CFRelease ] bi ] unit-test diff --git a/basis/core-foundation/core-foundation.factor b/basis/core-foundation/core-foundation.factor index d63a66dbe7..48d7b7e483 100644 --- a/basis/core-foundation/core-foundation.factor +++ b/basis/core-foundation/core-foundation.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings alien.syntax kernel -math sequences io.encodings.utf16 destructors accessors combinators ; +math sequences io.encodings.utf8 destructors accessors +combinators byte-arrays ; IN: core-foundation TYPEDEF: void* CFAllocatorRef @@ -69,12 +70,53 @@ FUNCTION: CFURLRef CFURLCreateWithString ( CFAllocatorRef allocator, CFStringRef FUNCTION: CFURLRef CFURLCopyFileSystemPath ( CFURLRef url, int pathStyle ) ; -FUNCTION: CFStringRef CFStringCreateWithCharacters ( CFAllocatorRef allocator, wchar_t* cStr, CFIndex numChars ) ; +TYPEDEF: int CFStringEncoding +: kCFStringEncodingMacRoman HEX: 0 ; +: kCFStringEncodingWindowsLatin1 HEX: 0500 ; +: kCFStringEncodingISOLatin1 HEX: 0201 ; +: kCFStringEncodingNextStepLatin HEX: 0B01 ; +: kCFStringEncodingASCII HEX: 0600 ; +: kCFStringEncodingUnicode HEX: 0100 ; +: kCFStringEncodingUTF8 HEX: 08000100 ; +: kCFStringEncodingNonLossyASCII HEX: 0BFF ; +: kCFStringEncodingUTF16 HEX: 0100 ; +: kCFStringEncodingUTF16BE HEX: 10000100 ; +: kCFStringEncodingUTF16LE HEX: 14000100 ; +: kCFStringEncodingUTF32 HEX: 0c000100 ; +: kCFStringEncodingUTF32BE HEX: 18000100 ; +: kCFStringEncodingUTF32LE HEX: 1c000100 ; + +FUNCTION: CFStringRef CFStringCreateFromExternalRepresentation ( + CFAllocatorRef alloc, + CFDataRef data, + CFStringEncoding encoding +) ; + +FUNCTION: CFStringRef CFStringCreateWithBytes ( + CFAllocatorRef alloc, + UInt8* bytes, + CFIndex numBytes, + CFStringEncoding encoding, + Boolean isExternalRepresentation +) ; FUNCTION: CFIndex CFStringGetLength ( CFStringRef theString ) ; FUNCTION: void CFStringGetCharacters ( void* theString, CFIndex start, CFIndex length, void* buffer ) ; +FUNCTION: Boolean CFStringGetCString ( + CFStringRef theString, + char* buffer, + CFIndex bufferSize, + CFStringEncoding encoding +) ; + +FUNCTION: CFStringRef CFStringCreateWithCString ( + CFAllocatorRef alloc, + char* cStr, + CFStringEncoding encoding +) ; + FUNCTION: CFNumberRef CFNumberCreate ( CFAllocatorRef allocator, CFNumberType theType, void* valuePtr ) ; FUNCTION: CFDataRef CFDataCreate ( CFAllocatorRef allocator, uchar* bytes, CFIndex length ) ; @@ -97,12 +139,16 @@ FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ; [ [ dupd ] dip CFArraySetValueAtIndex ] 2each ; : ( string -- alien ) - f swap dup length CFStringCreateWithCharacters ; + f swap utf8 string>alien kCFStringEncodingUTF8 CFStringCreateWithCString + [ "CFStringCreateWithCString failed" throw ] unless* ; : CF>string ( alien -- string ) - dup CFStringGetLength 1+ "ushort" [ - [ 0 over CFStringGetLength ] dip CFStringGetCharacters - ] keep utf16n alien>string ; + dup CFStringGetLength 4 * 1 + [ + dup length + kCFStringEncodingUTF8 + CFStringGetCString + [ "CFStringGetCString failed" throw ] unless + ] keep utf8 alien>string ; : CF>string-array ( alien -- seq ) CF>array [ CF>string ] map ; From 11c138ae95c7ffef8bfdd40beb0897723ff9b499 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Dec 2008 18:49:02 -0600 Subject: [PATCH 106/150] alien.strings doesn't load utf16 on Unix anymore --- basis/alien/strings/strings.factor | 29 +++++++++------------- basis/alien/strings/unix/unix.factor | 8 ++++++ basis/alien/strings/windows/windows.factor | 13 ++++++++++ 3 files changed, 33 insertions(+), 17 deletions(-) create mode 100644 basis/alien/strings/unix/unix.factor create mode 100644 basis/alien/strings/windows/windows.factor diff --git a/basis/alien/strings/strings.factor b/basis/alien/strings/strings.factor index d482634772..e9053cd5c1 100644 --- a/basis/alien/strings/strings.factor +++ b/basis/alien/strings/strings.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays sequences kernel accessors math alien.accessors alien.c-types byte-arrays words io io.encodings -io.streams.byte-array io.streams.memory io.encodings.utf8 -io.encodings.utf16 system alien strings cpu.architecture fry ; +io.encodings.utf8 io.streams.byte-array io.streams.memory system +alien strings cpu.architecture fry vocabs.loader combinators ; IN: alien.strings GENERIC# alien>string 1 ( c-ptr encoding -- string/f ) @@ -88,27 +88,22 @@ M: string-type c-type-getter M: string-type c-type-setter drop [ set-alien-cell ] ; -! Native-order UTF-16 +HOOK: alien>native-string os ( alien -- string ) -SINGLETON: utf16n - -: utf16n ( -- descriptor ) - little-endian? utf16le utf16be ? ; foldable - -M: utf16n drop utf16n ; - -M: utf16n drop utf16n ; - -: alien>native-string ( alien -- string ) - os windows? [ utf16n ] [ utf8 ] if alien>string ; +HOOK: native-string>alien os ( string -- alien ) : dll-path ( dll -- string ) path>> alien>native-string ; : string>symbol ( str -- alien ) - [ os wince? [ utf16n ] [ utf8 ] if string>alien ] - over string? [ call ] [ map ] if ; + dup string? + [ native-string>alien ] + [ [ native-string>alien ] map ] if ; { "char*" utf8 } "char*" typedef -{ "char*" utf16n } "wchar_t*" typedef "char*" "uchar*" typedef + +{ + { [ os windows? ] [ "alien.strings.windows" require ] } + { [ os unix? ] [ "alien.strings.unix" require ] } +} cond diff --git a/basis/alien/strings/unix/unix.factor b/basis/alien/strings/unix/unix.factor new file mode 100644 index 0000000000..a7b1467344 --- /dev/null +++ b/basis/alien/strings/unix/unix.factor @@ -0,0 +1,8 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.strings io.encodings.utf8 system ; +IN: alien.strings.unix + +M: unix alien>native-string utf8 alien>string ; + +M: unix native-string>alien utf8 string>alien ; diff --git a/basis/alien/strings/windows/windows.factor b/basis/alien/strings/windows/windows.factor new file mode 100644 index 0000000000..55c69246de --- /dev/null +++ b/basis/alien/strings/windows/windows.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.strings alien.c-types io.encodings.utf8 +io.encodings.utf16n system ; +IN: alien.strings.windows + +M: windows alien>native-string utf16n alien>string ; + +M: wince native-string>alien utf16n string>alien ; + +M: winnt native-string>alien utf8 string>alien ; + +{ "char*" utf16n } "wchar_t*" typedef From 1604e18d71640c714c376a5e68911bd6de99e2b8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Dec 2008 19:13:58 -0600 Subject: [PATCH 107/150] Remove ascii dependency from Mac OS X bootstrap --- basis/cocoa/messages/messages.factor | 6 +++--- basis/cocoa/subclassing/subclassing.factor | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 5f548bdeb8..ebe98a2df1 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -3,7 +3,7 @@ USING: accessors alien alien.c-types alien.strings arrays assocs continuations combinators compiler compiler.alien kernel math namespaces make parser quotations sequences strings words -cocoa.runtime io macros memoize io.encodings.ascii +cocoa.runtime io macros memoize io.encodings.utf8 effects libc libc.private parser lexer init core-foundation fry generalizations specialized-arrays.direct.alien ; IN: cocoa.messages @@ -180,7 +180,7 @@ assoc-union alien>objc-types set-global : method-arg-type ( method i -- type ) method_copyArgumentType - [ ascii alien>string parse-objc-type ] keep + [ utf8 alien>string parse-objc-type ] keep (free) ; : method-arg-types ( method -- args ) @@ -189,7 +189,7 @@ assoc-union alien>objc-types set-global : method-return-type ( method -- ctype ) method_copyReturnType - [ ascii alien>string parse-objc-type ] keep + [ utf8 alien>string parse-objc-type ] keep (free) ; : register-objc-method ( method -- ) diff --git a/basis/cocoa/subclassing/subclassing.factor b/basis/cocoa/subclassing/subclassing.factor index b49d55a30b..be53364185 100644 --- a/basis/cocoa/subclassing/subclassing.factor +++ b/basis/cocoa/subclassing/subclassing.factor @@ -3,12 +3,12 @@ USING: alien alien.c-types alien.strings arrays assocs combinators compiler hashtables kernel libc math namespaces parser sequences words cocoa.messages cocoa.runtime locals -compiler.units io.encodings.ascii continuations make fry ; +compiler.units io.encodings.utf8 continuations make fry ; IN: cocoa.subclassing : init-method ( method -- sel imp types ) first3 swap - [ sel_registerName ] [ execute ] [ ascii string>alien ] + [ sel_registerName ] [ execute ] [ utf8 string>alien ] tri* ; : throw-if-false ( obj what -- ) From 640b37cb70e643f6cf1fe2baa6b1b955c37927ff Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Dec 2008 19:14:18 -0600 Subject: [PATCH 108/150] More permissive --- basis/compiler/tree/propagation/inlining/inlining.factor | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index fcc3b01dc0..e35eb02604 100644 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -48,9 +48,11 @@ M: callable splicing-nodes ] [ 2drop f >>method f >>body f >>class drop f ] if ; : inlining-standard-method ( #call word -- class/f method/f ) - [ in-d>> ] [ [ dispatch# ] keep ] bi* - [ swap nth value-info class>> dup ] dip - specific-method ; + dup "methods" word-prop assoc-empty? [ 2drop f f ] [ + [ in-d>> ] [ [ dispatch# ] keep ] bi* + [ swap nth value-info class>> dup ] dip + specific-method + ] if ; : inline-standard-method ( #call word -- ? ) dupd inlining-standard-method eliminate-dispatch ; From 8c60595b26fc7353e5cb3bc6695d07c635277f0e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Dec 2008 19:14:38 -0600 Subject: [PATCH 109/150] Strip out default methods; ~40kb savings on hello-world and maze demos --- basis/tools/deploy/shaker/shaker.factor | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 01cc80e90d..3c458f0a55 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -185,6 +185,19 @@ IN: tools.deploy.shaker strip-word-names? [ dup strip-word-names ] when 2drop ; +: strip-default-methods ( -- ) + strip-debugger? [ + "Stripping default methods" show + [ + [ generic? ] instances + [ "No method" throw ] define-temp + dup t "default" set-word-prop + '[ + [ _ "default-method" set-word-prop ] [ make-generic ] bi + ] each + ] with-compilation-unit + ] when ; + : strip-vocab-globals ( except names -- words ) [ child-vocabs [ words ] map concat ] map concat swap diff ; @@ -370,6 +383,7 @@ SYMBOL: deploy-vocab : strip ( -- ) init-stripper + strip-default-methods strip-libc strip-cocoa strip-debugger @@ -395,7 +409,7 @@ SYMBOL: deploy-vocab deploy-vocab get require strip finish-deploy - ] [ die 1 exit ] recover + ] [ error-continuation get call>> callstack>array die 1 exit ] recover ] bind ; : do-deploy ( -- ) From 78fbaacb3c3fd1fdc79ebdd2f1917daa117a1f5a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Dec 2008 19:18:03 -0600 Subject: [PATCH 110/150] Don't include threading support with hello-world; this reduces size by ~30kb --- extra/hello-world/deploy.factor | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/extra/hello-world/deploy.factor b/extra/hello-world/deploy.factor index 64ea481b03..48c14f7cba 100755 --- a/extra/hello-world/deploy.factor +++ b/extra/hello-world/deploy.factor @@ -1,14 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-unicode? f } - { deploy-reflection 1 } - { deploy-word-props? f } - { deploy-math? f } { deploy-name "Hello world (console)" } - { deploy-word-defs? f } - { "stop-after-last-window?" t } - { deploy-ui? f } - { deploy-compiler? f } - { deploy-io 2 } { deploy-c-types? f } + { deploy-word-props? f } + { deploy-ui? f } + { deploy-reflection 1 } + { deploy-compiler? f } + { deploy-unicode? f } + { deploy-io 2 } + { deploy-word-defs? f } + { deploy-threads? f } + { "stop-after-last-window?" t } + { deploy-math? f } } From faa6989fe9cbc559cd6cd2d3c7e97dcdf24f74c0 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Tue, 9 Dec 2008 02:36:55 +0100 Subject: [PATCH 111/150] FUEL: First stab at the debugger: error/restart display and restart invokation. --- extra/fuel/fuel.factor | 118 ++++++++++++------ misc/fuel/README | 17 ++- misc/fuel/factor-mode.el | 17 +++ misc/fuel/fuel-debug.el | 234 ++++++++++++++++++++++++++++++++++++ misc/fuel/fuel-eval.el | 56 +++++++-- misc/fuel/fuel-font-lock.el | 33 ++--- misc/fuel/fuel-help.el | 7 +- misc/fuel/fuel-listener.el | 49 +++++--- misc/fuel/fuel-mode.el | 49 ++++++-- 9 files changed, 472 insertions(+), 108 deletions(-) create mode 100644 misc/fuel/fuel-debug.el diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index d8a363ca71..acaccf5b78 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -1,50 +1,70 @@ ! Copyright (C) 2008 Jose Antonio Ortega Ruiz. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays classes.tuple compiler.units continuations debugger -definitions eval io io.files io.streams.string kernel listener listener.private -make math namespaces parser prettyprint quotations sequences strings -vectors vocabs.loader ; +USING: accessors arrays classes classes.tuple compiler.units +combinators continuations debugger definitions eval help +io io.files io.streams.string kernel lexer listener listener.private +make math namespaces parser prettyprint prettyprint.config +quotations sequences strings source-files vectors vocabs.loader ; IN: fuel -! > in set ] - [ use>> clone use set ] - [ ds?>> display-stacks? swap [ on ] [ off ] if ] tri - ] unless ; - SYMBOL: fuel-eval-result f clone fuel-eval-result set-global SYMBOL: fuel-eval-output f clone fuel-eval-result set-global -! PRIVATE> +SYMBOL: fuel-eval-res-flag +t clone fuel-eval-res-flag set-global + +: fuel-eval-restartable? ( -- ? ) + fuel-eval-res-flag get-global ; inline + +: fuel-eval-restartable ( -- ) + t fuel-eval-res-flag set-global ; inline + +: fuel-eval-non-restartable ( -- ) + f fuel-eval-res-flag set-global ; inline + +: push-fuel-status ( -- ) + in get use get clone display-stacks? get restarts get-global clone + fuel-status boa + fuel-status-stack get push ; + +: pop-fuel-status ( -- ) + fuel-status-stack get empty? [ + fuel-status-stack get pop { + [ in>> in set ] + [ use>> clone use set ] + [ ds?>> display-stacks? swap [ on ] [ off ] if ] + [ + restarts>> fuel-eval-restartable? [ drop ] [ + clone restarts set-global + ] if + ] + } cleave + ] unless ; + + +! Lispy pretty printing GENERIC: fuel-pprint ( obj -- ) -M: object fuel-pprint pprint ; +M: object fuel-pprint pprint ; inline -M: f fuel-pprint drop "nil" write ; +M: f fuel-pprint drop "nil" write ; inline -M: integer fuel-pprint pprint ; +M: integer fuel-pprint pprint ; inline -M: string fuel-pprint pprint ; +M: string fuel-pprint pprint ; inline M: sequence fuel-pprint dup empty? [ drop f fuel-pprint ] [ @@ -53,12 +73,30 @@ M: sequence fuel-pprint ")" write ] if ; -M: tuple fuel-pprint tuple>array fuel-pprint ; +M: tuple fuel-pprint tuple>array fuel-pprint ; inline -M: continuation fuel-pprint drop "~continuation~" write ; +M: continuation fuel-pprint drop ":continuation" write ; inline + +M: restart fuel-pprint name>> fuel-pprint ; inline + +SYMBOL: :restarts + +: fuel-restarts ( obj -- seq ) + compute-restarts :restarts prefix ; inline + +M: condition fuel-pprint + [ error>> ] [ fuel-restarts ] bi 2array condition prefix fuel-pprint ; + +M: source-file-error fuel-pprint + [ file>> ] [ error>> ] bi 2array source-file-error prefix + fuel-pprint ; + +M: source-file fuel-pprint path>> fuel-pprint ; + +! Evaluation vocabulary : fuel-eval-set-result ( obj -- ) - clone fuel-eval-result set-global ; + clone fuel-eval-result set-global ; inline : fuel-retort ( -- ) error get @@ -67,7 +105,7 @@ M: continuation fuel-pprint drop "~continuation~" write ; 3array fuel-pprint ; : fuel-forget-error ( -- ) - f error set-global ; + f error set-global ; inline : (fuel-begin-eval) ( -- ) push-fuel-status @@ -76,23 +114,25 @@ M: continuation fuel-pprint drop "~continuation~" write ; f fuel-eval-result set-global f fuel-eval-output set-global ; +: fuel-run-with-output ( quot -- ) + with-string-writer fuel-eval-output set-global ; inline + : (fuel-end-eval) ( quot -- ) - with-string-writer fuel-eval-output set-global - fuel-retort - pop-fuel-status ; + fuel-run-with-output fuel-retort pop-fuel-status ; inline : (fuel-eval) ( lines -- ) - [ [ parse-lines ] with-compilation-unit call ] curry [ drop ] recover ; + [ [ parse-lines ] with-compilation-unit call ] curry + [ print-error ] recover ; inline : (fuel-eval-each) ( lines -- ) - [ 1vector (fuel-eval) ] each ; + [ 1vector (fuel-eval) ] each ; inline : (fuel-eval-usings) ( usings -- ) [ "USING: " prepend " ;" append ] map (fuel-eval-each) fuel-forget-error ; : (fuel-eval-in) ( in -- ) - [ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ; + [ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ; inline : fuel-eval-in-context ( lines in usings -- ) (fuel-begin-eval) [ @@ -107,15 +147,15 @@ M: continuation fuel-pprint drop "~continuation~" write ; fuel-retort ; : fuel-eval ( lines -- ) - (fuel-begin-eval) [ (fuel-eval) ] (fuel-end-eval) ; + (fuel-begin-eval) [ (fuel-eval) ] (fuel-end-eval) ; inline -: fuel-end-eval ( -- ) - [ ] (fuel-end-eval) ; +: fuel-end-eval ( -- ) [ ] (fuel-end-eval) ; inline : fuel-get-edit-location ( defspec -- ) where [ first2 [ (normalize-path) ] dip 2array fuel-eval-set-result ] when* ; -: fuel-startup ( -- ) - "listener" run ; +: fuel-run-file ( path -- ) run-file ; inline + +: fuel-startup ( -- ) "listener" run ; inline MAIN: fuel-startup diff --git a/misc/fuel/README b/misc/fuel/README index 078490abfd..18f6fa1e94 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -47,18 +47,29 @@ M-x customize-group fuel will show you how many. Quick key reference ------------------- +(Chords ending in a single letter accept also C- (e.g. C-cC-z is +the same as C-cz)). + +* In factor files: + - C-cz : switch to listener - C-co : cycle between code, tests and docs factor files - - M-. : edit word at point in Emacs + - M-. : edit word at point in Emacs (also in listener) - C-cr, C-cC-er : eval region - C-M-r, C-cC-ee : eval region, extending it to definition boundaries - C-M-x, C-cC-ex : eval definition around point + - C-ck, C-cC-ek : compile file - C-cC-da : toggle autodoc mode - C-cC-dd : help for word at point - C-cC-ds : short help word at point -Chords ending in a single letter accept also C- (e.g. C-cC-z is -the same as C-cz). +* In the debugger (it pops up upon eval/compilation errors): + + - g : go to error + - : invoke nth restart + - q : bury buffer + + diff --git a/misc/fuel/factor-mode.el b/misc/fuel/factor-mode.el index d79930bb22..b3952074f5 100644 --- a/misc/fuel/factor-mode.el +++ b/misc/fuel/factor-mode.el @@ -59,6 +59,23 @@ code in the buffer." :type 'hook :group 'factor-mode) + +;;; Faces: + +(fuel-font-lock--define-faces + factor-font-lock font-lock factor-mode + ((comment comment "comments") + (constructor type "constructors ()") + (declaration keyword "declaration words") + (parsing-word keyword "parsing words") + (setter-word function-name "setter words (>>foo)") + (stack-effect comment "stack effect specifications") + (string string "strings") + (symbol variable-name "name of symbol being defined") + (type-name type "type names") + (vocabulary-name constant "vocabulary names") + (word function-name "word, generic or method being defined"))) + ;;; Syntax table: diff --git a/misc/fuel/fuel-debug.el b/misc/fuel/fuel-debug.el new file mode 100644 index 0000000000..1b68f6e79f --- /dev/null +++ b/misc/fuel/fuel-debug.el @@ -0,0 +1,234 @@ +;;; fuel-debug.el -- debugging factor code + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages, fuel, factor +;; Start date: Sun Dec 07, 2008 04:16 + +;;; Comentary: + +;; A mode for displaying the results of run-file and evaluation, with +;; support for restarts. + +;;; Code: + +(require 'fuel-base) +(require 'fuel-eval) +(require 'fuel-font-lock) + + +;;; Customization: + +(defgroup fuel-debug nil + "Major mode for interaction with the Factor debugger" + :group 'fuel) + +(defcustom fuel-debug-mode-hook nil + "Hook run after `fuel-debug-mode' activates" + :group 'fuel-debug + :type 'hook) + +(defcustom fuel-debug-show-short-help t + "Whether to show short help on available keys in debugger" + :group 'fuel-debug + :type 'boolean) + +(fuel-font-lock--define-faces + fuel-debug-font-lock font-lock fuel-debug + ((error warning "highlighting errors") + (line variable-name "line numbers in errors/warnings") + (column variable-name "column numbers in errors/warnings") + (info comment "information headers") + (restart-number warning "restart numbers") + (restart-name function-name "restart names"))) + + +;;; Compilation results buffer: + +(defvar fuel-debug--buffer nil) + +(make-variable-buffer-local + (defvar fuel-debug--last-ret nil)) + +(make-variable-buffer-local + (defvar fuel-debug--file nil)) + +(defun fuel-debug--buffer () + (or (and (buffer-live-p fuel-debug--buffer) fuel-debug--buffer) + (with-current-buffer + (setq fuel-debug--buffer (get-buffer-create "*fuel dbg*")) + (fuel-debug-mode) + (current-buffer)))) + +(defun fuel-debug--display-retort (ret &optional success-msg no-pop file) + (let ((err (fuel-eval--retort-error ret)) + (inhibit-read-only t)) + (with-current-buffer (fuel-debug--buffer) + (erase-buffer) + (when err (insert (format "Error: %S\n\n" (fuel-eval--error-name err)))) + (fuel-debug--display-output-1 ret) + (when (and (not err) success-msg) + (message "%s" success-msg) + (insert "\n" success-msg "\n")) + (when err + (fuel-debug--display-restarts err) + (let ((hstr (fuel-debug--help-string err))) + (if fuel-debug-show-short-help + (insert "-----------\n" hstr "\n") + (message "%s" hstr)))) + (setq fuel-debug--last-ret ret) + (setq fuel-debug--file file) + (goto-char (point-max))) + (when (and err (not no-pop)) (pop-to-buffer fuel-debug--buffer)))) + +(defun fuel-debug--display-output-1 (ret) + (let* ((last (fuel-eval--retort-output fuel-debug--last-ret)) + (current (fuel-eval--retort-output ret)) + (llen (length last)) + (clen (length current)) + (trail (and last (substring-no-properties last (/ llen 2)))) + (p (point))) + (save-excursion (insert current)) + (when (and (> clen llen) (> llen 0) (search-forward trail nil t)) + (delete-region p (point))) + (goto-char (point-max)))) + +(defun fuel-debug--display-restarts (err) + (let* ((rs (fuel-eval--error-restarts err)) + (rsn (length rs))) + (when rs + (insert "\n\nRestarts:\n\n") + (dotimes (n rsn) + (insert (format ":%s %s\n" (1+ n) (nth n rs)))) + (newline)))) + +(defun fuel-debug--help-string (err) + (format "Press %s%s 'q' to bury buffer" + (if (fuel-eval--error-file err) "g to visit file, " "") + (let ((rsn (length (fuel-eval--error-restarts err)))) + (cond ((zerop rsn) "") + ((= 1 rsn) "1 to invoke restart, ") + (t (format "1-%s to invoke restarts, " rsn)))))) + +(defun fuel-debug--buffer-file () + (with-current-buffer (fuel-debug--buffer) + (or fuel-debug--file + (and fuel-debug--last-ret + (fuel-eval--error-file + (fuel-eval--retort-error fuel-debug--last-ret)))))) + +(defsubst fuel-debug--buffer-error () + (fuel-eval--retort-error fuel-debug--last-ret)) + +(defsubst fuel-debug--buffer-restarts () + (fuel-eval--error-restarts (fuel-debug--buffer-error))) + + +;;; Font lock and other pattern matching: + +(defconst fuel-debug--error-file-regex "^P\" \\([^\"]+\\)\"") +(defconst fuel-debug--error-line-regex "\\([0-9]+\\):") +(defconst fuel-debug--error-cont-regex "^ +\\(\\^\\)$") + +(defconst fuel-debug--error-regex + (format "%s\n%s" + fuel-debug--error-file-regex + fuel-debug--error-line-regex)) + +(defconst fuel-debug--named-restart-regex + (format "^\\(%s\\) " (regexp-opt '(":warnings" ":errors" ":linkage")))) + +(defconst fuel-debug--restart-regex + "^:\\([0-9]+\\) \\(.+\\)") + +(defconst fuel-debug--font-lock-keywords + `((,fuel-debug--error-file-regex . 'fuel-debug-font-lock-error) + (,fuel-debug--error-line-regex 1 'fuel-debug-font-lock-line) + (,fuel-debug--error-cont-regex 1 'fuel-debug-font-lock-column) + (,fuel-debug--restart-regex (1 'fuel-debug-font-lock-restart-number) + (2 'fuel-debug-font-lock-restart-name)) + (,fuel-debug--named-restart-regex 1 'fuel-debug-font-lock-restart-number) + ("^\\(Restarts?\\|Loading\\) .+$" . 'fuel-debug-font-lock-info) + ("^Error: " . 'fuel-debug-font-lock-error))) + +(defun fuel-debug--font-lock-setup () + (set (make-local-variable 'font-lock-defaults) + '(fuel-debug--font-lock-keywords t nil nil nil))) + +;;; Buffer navigation: + +(defun fuel-debug-goto-error () + (interactive) + (let* ((err (or (fuel-debug--buffer-error) + (error "No errors reported"))) + (file (or (fuel-eval--error-file err) + (error "No file associated with error"))) + (l/c (fuel-eval--error-line/column err)) + (line (or (car l/c) 1)) + (col (or (cdr l/c) 0))) + (find-file-other-window file) + (goto-line line) + (forward-char col))) + +(defun fuel-debug--read-restart-no () + (let ((rs (fuel-debug--buffer-restarts))) + (unless rs (error "No restarts available")) + (let* ((rsn (length rs)) + (prompt (format "Restart number? (1-%s): " rsn)) + (no 0)) + (while (or (> (setq no (read-number prompt)) rsn) + (< no 1))) + no))) + +(defun fuel-debug-exec-restart (&optional n confirm) + (interactive (list (fuel-debug--read-restart-no))) + (let ((n (or n 1)) + (rs (fuel-debug--buffer-restarts))) + (when (zerop (length rs)) + (error "No restarts available")) + (when (or (< n 1) (> n (length rs))) + (error "Restart %s not available" n)) + (when (or (not confirm) + (y-or-n-p (format "Invoke restart %s? " n))) + (message "Invoking restart %s" n) + (let* ((file (fuel-debug--buffer-file)) + (buffer (if file (find-file-noselect file) (current-buffer)))) + (with-current-buffer buffer + (fuel-debug--display-retort + (fuel-eval--eval-string/context (format ":%s" n)) + (format "Restart %s (%s) successful" n (nth (1- n) rs)))))))) + + +;;; Fuel Debug mode: + +(defvar fuel-debug-mode-map + (let ((map (make-keymap))) + (suppress-keymap map) + (define-key map "g" 'fuel-debug-goto-error) + (define-key map "\C-c\C-c" 'fuel-debug-goto-error) + (define-key map "q" 'bury-buffer) + (dotimes (n 9) + (define-key map (vector (+ ?1 n)) + `(lambda () (interactive) (fuel-debug-exec-restart ,(1+ n) t)))) + map)) + +(defun fuel-debug-mode () + "A major mode for displaying Factor's compilation results and +invoking restarts as needed. +\\{fuel-debug-mode-map}" + (interactive) + (kill-all-local-variables) + (setq major-mode 'factor-mode) + (setq mode-name "Fuel Debug") + (use-local-map fuel-debug-mode-map) + (fuel-debug--font-lock-setup) + (setq fuel-debug--file nil) + (setq fuel-debug--last-ret nil) + (toggle-read-only 1) + (run-hooks 'fuel-debug-mode-hook)) + + +(provide 'fuel-debug) +;;; fuel-debug.el ends here diff --git a/misc/fuel/fuel-eval.el b/misc/fuel/fuel-eval.el index bef7171f6f..62001cc48c 100644 --- a/misc/fuel/fuel-eval.el +++ b/misc/fuel/fuel-eval.el @@ -38,7 +38,8 @@ (when (and (> fuel-eval-log-max-length 0) (> (point) fuel-eval-log-max-length)) (erase-buffer)) - (when fuel-eval--log (insert "\n>> " (fuel--shorten-str str 256) "\n")) + (when fuel-eval--log (insert "\n>> " (fuel--shorten-str str 256))) + (newline) (let ((beg (point))) (comint-redirect-send-command-to-process str (current-buffer) proc nil t) (with-current-buffer (process-buffer proc) @@ -58,8 +59,6 @@ (defsubst fuel-eval--retort-p (ret) (listp ret)) -(defsubst fuel-eval--error-name (err) (car err)) - (defsubst fuel-eval--make-parse-error-retort (str) (fuel-eval--retort-make 'parse-retort-error nil str)) @@ -83,29 +82,60 @@ (defsubst fuel-eval--factor-array (strs) (format "V{ %S }" (mapconcat 'identity strs " "))) -(defsubst fuel-eval--eval-strings (strs) - (let ((str (format "%s fuel-eval" (fuel-eval--factor-array strs)))) +(defsubst fuel-eval--eval-strings (strs &optional no-restart) + (let ((str (format "fuel-eval-%s %s fuel-eval" + (if no-restart "non-restartable" "restartable") + (fuel-eval--factor-array strs)))) (fuel-eval--send/retort str))) -(defsubst fuel-eval--eval-string (str) - (fuel-eval--eval-strings (list str))) +(defsubst fuel-eval--eval-string (str &optional no-restart) + (fuel-eval--eval-strings (list str) no-restart)) -(defun fuel-eval--eval-strings/context (strs) +(defun fuel-eval--eval-strings/context (strs &optional no-restart) (let ((usings (fuel-syntax--usings-update))) (fuel-eval--send/retort - (format "%s %S %s fuel-eval-in-context" + (format "fuel-eval-%s %s %S %s fuel-eval-in-context" + (if no-restart "non-restartable" "restartable") (fuel-eval--factor-array strs) (or fuel-syntax--current-vocab "f") (if usings (fuel-eval--factor-array usings) "f"))))) -(defsubst fuel-eval--eval-string/context (str) - (fuel-eval--eval-strings/context (list str))) +(defsubst fuel-eval--eval-string/context (str &optional no-restart) + (fuel-eval--eval-strings/context (list str) no-restart)) -(defun fuel-eval--eval-region/context (begin end) +(defun fuel-eval--eval-region/context (begin end &optional no-restart) (let ((lines (split-string (buffer-substring-no-properties begin end) "[\f\n\r\v]+" t))) (when (> (length lines) 0) - (fuel-eval--eval-strings/context lines)))) + (fuel-eval--eval-strings/context lines no-restart)))) + + +;;; Error parsing + +(defsubst fuel-eval--error-name (err) (car err)) + +(defsubst fuel-eval--error-restarts (err) + (cdr (assoc :restarts (fuel-eval--error-name-p err 'condition)))) + +(defun fuel-eval--error-name-p (err name) + (unless (null err) + (or (and (eq (fuel-eval--error-name err) name) err) + (assoc name err)))) + +(defsubst fuel-eval--error-file (err) + (nth 1 (fuel-eval--error-name-p err 'source-file-error))) + +(defsubst fuel-eval--error-lexer-p (err) + (or (fuel-eval--error-name-p err 'lexer-error) + (fuel-eval--error-name-p (fuel-eval--error-name-p err 'source-file-error) + 'lexer-error))) + +(defsubst fuel-eval--error-line/column (err) + (let ((err (fuel-eval--error-lexer-p err))) + (cons (nth 1 err) (nth 2 err)))) + +(defsubst fuel-eval--error-line-text (err) + (nth 3 (fuel-eval--error-lexer-p err))) (provide 'fuel-eval) diff --git a/misc/fuel/fuel-font-lock.el b/misc/fuel/fuel-font-lock.el index c8673f742b..4c710635ba 100644 --- a/misc/fuel/fuel-font-lock.el +++ b/misc/fuel/fuel-font-lock.el @@ -21,30 +21,23 @@ ;;; Faces: -(defmacro fuel-font-lock--face (face def doc) - (let ((face (intern (format "factor-font-lock-%s" (symbol-name face)))) - (def (intern (format "font-lock-%s-face" (symbol-name def))))) +(defmacro fuel-font-lock--make-face (prefix def-prefix group face def doc) + (let ((face (intern (format "%s-%s" prefix face))) + (def (intern (format "%s-%s-face" def-prefix def)))) `(defface ,face (face-default-spec ,def) ,(format "Face for %s." doc) - :group 'factor-mode + :group ',group :group 'faces))) -(defmacro fuel-font-lock--faces-setup () - (cons 'progn - (mapcar (lambda (f) (cons 'fuel-font-lock--face f)) - '((comment comment "comments") - (constructor type "constructors ()") - (declaration keyword "declaration words") - (parsing-word keyword "parsing words") - (setter-word function-name "setter words (>>foo)") - (stack-effect comment "stack effect specifications") - (string string "strings") - (symbol variable-name "name of symbol being defined") - (type-name type "type names") - (vocabulary-name constant "vocabulary names") - (word function-name "word, generic or method being defined"))))) - -(fuel-font-lock--faces-setup) +(defmacro fuel-font-lock--define-faces (prefix def-prefix group faces) + (let ((setup (make-symbol (format "%s--faces-setup" prefix)))) + `(progn + (defmacro ,setup () + (cons 'progn + (mapcar (lambda (f) (append '(fuel-font-lock--make-face + ,prefix ,def-prefix ,group) f)) + ',faces))) + (,setup)))) ;;; Font lock: diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index dcf17d2716..1db9b25d69 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -68,10 +68,11 @@ (defun fuel-help--word-synopsis (&optional word) (let ((word (or word (fuel-syntax-symbol-at-point))) - (fuel-eval--log nil)) + (fuel-eval--log t)) (when word (let ((ret (fuel-eval--eval-string/context - (format "\\ %s synopsis fuel-eval-set-result" word)))) + (format "\\ %s synopsis fuel-eval-set-result" word) + t))) (when (not (fuel-eval--retort-error ret)) (if fuel-help-minibuffer-font-lock (fuel-help--font-lock-str (fuel-eval--retort-result ret)) @@ -170,7 +171,7 @@ displayed in the minibuffer." (def (if ask (read-string prompt nil 'fuel-help--history def) def)) (cmd (format "\\ %s %s" def (if see "see" "help"))) (fuel-eval--log nil) - (ret (fuel-eval--eval-string/context cmd)) + (ret (fuel-eval--eval-string/context cmd t)) (out (fuel-eval--retort-output ret))) (if (or (fuel-eval--retort-error ret) (empty-string-p out)) (message "No help for '%s'" def) diff --git a/misc/fuel/fuel-listener.el b/misc/fuel/fuel-listener.el index c741a77a5d..9fa330993c 100644 --- a/misc/fuel/fuel-listener.el +++ b/misc/fuel/fuel-listener.el @@ -59,10 +59,15 @@ buffer." (error "Could not run factor: %s is not executable" factor)) (unless (file-readable-p image) (error "Could not run factor: image file %s not readable" image)) - (setq fuel-listener-buffer - (make-comint "fuel listener" factor nil "-run=fuel" (format "-i=%s" image))) + (setq fuel-listener-buffer (get-buffer-create "*fuel listener*")) (with-current-buffer fuel-listener-buffer - (fuel-listener-mode)))) + (fuel-listener-mode) + (message "Starting FUEL listener ...") + (comint-exec fuel-listener-buffer "factor" + factor nil `("-run=fuel" ,(format "-i=%s" image))) + (fuel-listener--wait-for-prompt 20) + (fuel-eval--send-string "USE: fuel") + (message "FUEL listener up and running!")))) (defun fuel-listener--process (&optional start) (or (and (buffer-live-p fuel-listener-buffer) @@ -74,6 +79,23 @@ buffer." (setq fuel-eval--default-proc-function 'fuel-listener--process) + +;;; Prompt chasing + +(defun fuel-listener--wait-for-prompt (&optional timeout) + (let ((proc (get-buffer-process fuel-listener-buffer)) + (seen)) + (with-current-buffer fuel-listener-buffer + (while (progn (goto-char comint-last-input-end) + (not (or seen + (setq seen + (re-search-forward comint-prompt-regexp nil t)) + (not (accept-process-output proc timeout)))))) + (goto-char (point-max))) + (unless seen + (pop-to-buffer fuel-listener-buffer) + (error "No prompt found!")))) + ;;; Interface: starting fuel listener @@ -94,30 +116,17 @@ buffer." (defconst fuel-listener--prompt-regex "( [^)]* ) ") -(defun fuel-listener--wait-for-prompt (&optional timeout) - (let ((proc (fuel-listener--process))) - (with-current-buffer fuel-listener-buffer - (goto-char comint-last-input-end) - (while (not (or (re-search-forward comint-prompt-regexp nil t) - (not (accept-process-output proc timeout)))) - (goto-char comint-last-input-end)) - (goto-char (point-max))))) - -(defun fuel-listener--startup () - (fuel-listener--wait-for-prompt) - (fuel-eval--send-string "USE: fuel") - (message "FUEL listener up and running!")) - (define-derived-mode fuel-listener-mode comint-mode "Fuel Listener" "Major mode for interacting with an inferior Factor listener process. \\{fuel-listener-mode-map}" (set (make-local-variable 'comint-prompt-regexp) fuel-listener--prompt-regex) (set (make-local-variable 'comint-prompt-read-only) t) - (fuel-listener--startup)) + (setq fuel-listener--compilation-begin nil)) -;; (define-key fuel-listener-mode-map "\C-w" 'comint-kill-region) -;; (define-key fuel-listener-mode-map "\C-k" 'comint-kill-whole-line) +(define-key fuel-listener-mode-map "\C-ch" 'fuel-help) +(define-key fuel-listener-mode-map "\M-." 'fuel-edit-word-at-point) +(define-key fuel-listener-mode-map "\C-ck" 'fuel-run-file) (provide 'fuel-listener) diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index bd9b127c7d..0a459e4381 100644 --- a/misc/fuel/fuel-mode.el +++ b/misc/fuel/fuel-mode.el @@ -18,6 +18,7 @@ (require 'fuel-base) (require 'fuel-syntax) (require 'fuel-font-lock) +(require 'fuel-debug) (require 'fuel-help) (require 'fuel-eval) (require 'fuel-listener) @@ -37,33 +38,58 @@ ;;; User commands +(defun fuel-run-file (&optional arg) + "Sends the current file to Factor for compilation. +With prefix argument, ask for the file to run." + (interactive "P") + (let* ((file (or (and arg (read-file-name "File: " nil (buffer-file-name) t)) + (buffer-file-name))) + (file (expand-file-name file)) + (buffer (find-file-noselect file)) + (cmd (format "%S fuel-run-file" file))) + (when buffer + (with-current-buffer buffer + (fuel-debug--display-retort (fuel-eval--eval-string/context cmd) + (format "%s successfully compiled" file) + nil + file))))) + (defun fuel-eval-region (begin end &optional arg) "Sends region to Fuel's listener for evaluation. -With prefix, switchs to the listener's buffer afterwards." +Unless called with a prefix, switchs to the compilation results +buffer in case of errors." (interactive "r\nP") - (let* ((ret (fuel-eval--eval-region/context begin end)) - (err (fuel-eval--retort-error ret))) - (message "%s" (or err (fuel--shorten-region begin end 70)))) - (when arg (pop-to-buffer fuel-listener-buffer))) + (fuel-debug--display-retort + (fuel-eval--eval-region/context begin end) + (format "%s%s" + (if fuel-syntax--current-vocab + (format "IN: %s " fuel-syntax--current-vocab) + "") + (fuel--shorten-region begin end 70)) + arg + (buffer-file-name))) (defun fuel-eval-extended-region (begin end &optional arg) "Sends region extended outwards to nearest definitions, -to Fuel's listener for evaluation. With prefix, switchs to the -listener's buffer afterwards." +to Fuel's listener for evaluation. +Unless called with a prefix, switchs to the compilation results +buffer in case of errors." (interactive "r\nP") (fuel-eval-region (save-excursion (goto-char begin) (mark-defun) (point)) - (save-excursion (goto-char end) (mark-defun) (mark)))) + (save-excursion (goto-char end) (mark-defun) (mark)) + arg)) (defun fuel-eval-definition (&optional arg) "Sends definition around point to Fuel's listener for evaluation. -With prefix, switchs to the listener's buffer afterwards." +Unless called with a prefix, switchs to the compilation results +buffer in case of errors." (interactive "P") (save-excursion (mark-defun) (let* ((begin (point)) (end (mark))) (unless (< begin end) (error "No evaluable definition around point")) - (fuel-eval-region begin end)))) + (fuel-eval-region begin end arg)))) (defun fuel-edit-word-at-point (&optional arg) "Opens a new window visiting the definition of the word at point. @@ -128,6 +154,9 @@ interacting with a factor listener is at your disposal. (fuel-mode--key-1 ?z 'run-factor) +(fuel-mode--key-1 ?k 'fuel-run-file) +(fuel-mode--key ?e ?k 'fuel-run-file) + (define-key fuel-mode-map "\C-\M-x" 'fuel-eval-definition) (fuel-mode--key ?e ?x 'fuel-eval-definition) From ada08e6d0edeb2d7bc66abf5d731f7a381c9ce7f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Dec 2008 19:45:48 -0600 Subject: [PATCH 112/150] Removing prettyprint and debugger dependencies from io code --- basis/io/encodings/utf16n/utf16n.factor | 15 +++++++++++++++ basis/io/ports/ports.factor | 2 +- basis/io/servers/connection/connection.factor | 2 +- basis/io/sockets/secure/openssl/openssl.factor | 4 ++-- basis/io/sockets/sockets.factor | 2 +- basis/io/streams/duplex/duplex.factor | 4 ++-- basis/io/unix/launcher/launcher.factor | 2 +- basis/io/unix/sockets/secure/secure.factor | 2 +- 8 files changed, 24 insertions(+), 9 deletions(-) create mode 100644 basis/io/encodings/utf16n/utf16n.factor diff --git a/basis/io/encodings/utf16n/utf16n.factor b/basis/io/encodings/utf16n/utf16n.factor new file mode 100644 index 0000000000..2fae7bd66a --- /dev/null +++ b/basis/io/encodings/utf16n/utf16n.factor @@ -0,0 +1,15 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types io.encodings io.encodings.utf16 ; +IN: io.encodings.utf16n + +! Native-order UTF-16 + +SINGLETON: utf16n + +: utf16n ( -- descriptor ) + little-endian? utf16le utf16be ? ; foldable + +M: utf16n drop utf16n ; + +M: utf16n drop utf16n ; diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index 0432fe4a39..6eb61a24a7 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: math kernel io sequences io.buffers io.timeouts generic byte-vectors system io.encodings math.order io.backend -continuations debugger classes byte-arrays namespaces splitting +continuations classes byte-arrays namespaces splitting grouping dlists assocs io.encodings.binary summary accessors destructors combinators ; IN: io.ports diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor index 2d990e6483..bc90915213 100644 --- a/basis/io/servers/connection/connection.factor +++ b/basis/io/servers/connection/connection.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: continuations destructors kernel math math.parser -namespaces parser sequences strings prettyprint debugger +namespaces parser sequences strings prettyprint quotations combinators logging calendar assocs present fry accessors arrays io io.sockets io.encodings.ascii io.sockets.secure io.files io.streams.duplex io.timeouts diff --git a/basis/io/sockets/secure/openssl/openssl.factor b/basis/io/sockets/secure/openssl/openssl.factor index ec45337fb1..60402c37ea 100644 --- a/basis/io/sockets/secure/openssl/openssl.factor +++ b/basis/io/sockets/secure/openssl/openssl.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors byte-arrays kernel debugger sequences +USING: accessors byte-arrays kernel sequences namespaces math math.order combinators init alien alien.c-types -alien.strings libc continuations destructors debugger summary +alien.strings libc continuations destructors summary splitting assocs random math.parser locals unicode.case openssl openssl.libcrypto openssl.libssl io.backend io.ports io.files io.encodings.8-bit io.timeouts io.sockets.secure ; diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index fbfae333c0..597aa61138 100644 --- a/basis/io/sockets/sockets.factor +++ b/basis/io/sockets/sockets.factor @@ -4,7 +4,7 @@ USING: generic kernel io.backend namespaces continuations sequences arrays io.encodings io.ports io.streams.duplex io.encodings.ascii alien.strings io.binary accessors destructors -classes debugger byte-arrays system combinators parser +classes byte-arrays system combinators parser alien.c-types math.parser splitting grouping math assocs summary system vocabs.loader combinators present fry ; IN: io.sockets diff --git a/basis/io/streams/duplex/duplex.factor b/basis/io/streams/duplex/duplex.factor index 9bf637432f..53d554e766 100644 --- a/basis/io/streams/duplex/duplex.factor +++ b/basis/io/streams/duplex/duplex.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel continuations destructors io io.encodings -io.encodings.private io.timeouts io.ports debugger summary -listener accessors delegate delegate.protocols ; +io.encodings.private io.timeouts io.ports summary +accessors delegate delegate.protocols ; IN: io.streams.duplex TUPLE: duplex-stream in out ; diff --git a/basis/io/unix/launcher/launcher.factor b/basis/io/unix/launcher/launcher.factor index c81da60e12..0101ed613b 100644 --- a/basis/io/unix/launcher/launcher.factor +++ b/basis/io/unix/launcher/launcher.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces math system sequences debugger +USING: kernel namespaces math system sequences continuations arrays assocs combinators alien.c-types strings threads accessors environment io io.backend io.launcher io.ports io.files diff --git a/basis/io/unix/sockets/secure/secure.factor b/basis/io/unix/sockets/secure/secure.factor index a096380b74..106b6569ed 100644 --- a/basis/io/unix/sockets/secure/secure.factor +++ b/basis/io/unix/sockets/secure/secure.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors unix byte-arrays kernel debugger sequences +USING: accessors unix byte-arrays kernel sequences namespaces math math.order combinators init alien alien.c-types alien.strings libc continuations destructors openssl openssl.libcrypto openssl.libssl io io.files io.ports From 10e3e84a5e64a4e878cd96b560c7287409d709e4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Dec 2008 19:45:58 -0600 Subject: [PATCH 113/150] Remove listener dependency from delegate --- basis/delegate/delegate.factor | 4 +--- basis/delegate/protocols/protocols.factor | 5 ++--- 2 files changed, 3 insertions(+), 6 deletions(-) diff --git a/basis/delegate/delegate.factor b/basis/delegate/delegate.factor index e7ea370b8d..57f9b35c96 100644 --- a/basis/delegate/delegate.factor +++ b/basis/delegate/delegate.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors parser generic kernel classes classes.tuple words slots assocs sequences arrays vectors definitions -prettyprint math hashtables sets generalizations namespaces make ; +math hashtables sets generalizations namespaces make ; IN: delegate : protocol-words ( protocol -- words ) @@ -100,6 +100,4 @@ M: protocol definition protocol-words show-words ; M: protocol definer drop \ PROTOCOL: \ ; ; -M: protocol synopsis* word-synopsis ; ! Necessary? - M: protocol group-words protocol-words ; diff --git a/basis/delegate/protocols/protocols.factor b/basis/delegate/protocols/protocols.factor index 81310c16c0..c21f33ec8e 100644 --- a/basis/delegate/protocols/protocols.factor +++ b/basis/delegate/protocols/protocols.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2007 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: delegate sequences.private sequences assocs -prettyprint.sections io definitions kernel continuations -listener ; +io definitions kernel continuations ; IN: delegate.protocols PROTOCOL: sequence-protocol @@ -16,7 +15,7 @@ PROTOCOL: assoc-protocol PROTOCOL: input-stream-protocol stream-read1 stream-read stream-read-partial stream-readln - stream-read-until stream-read-quot ; + stream-read-until ; PROTOCOL: output-stream-protocol stream-flush stream-write1 stream-write stream-format From 97a91579bbca148fc708ff9de773a1ebf3f98dc9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Dec 2008 19:46:07 -0600 Subject: [PATCH 114/150] Fix load error --- extra/parser-combinators/regexp/regexp.factor | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/extra/parser-combinators/regexp/regexp.factor b/extra/parser-combinators/regexp/regexp.factor index b13321d991..7c23dcce0b 100755 --- a/extra/parser-combinators/regexp/regexp.factor +++ b/extra/parser-combinators/regexp/regexp.factor @@ -1,8 +1,9 @@ USING: arrays combinators kernel lists math math.parser -namespaces parser lexer parser-combinators parser-combinators.simple -promises quotations sequences strings math.order -assocs prettyprint.backend memoize unicode.case unicode.categories -combinators.short-circuit accessors make io ; +namespaces parser lexer parser-combinators +parser-combinators.simple promises quotations sequences strings +math.order assocs prettyprint.backend prettyprint.custom memoize +unicode.case unicode.categories combinators.short-circuit +accessors make io ; IN: parser-combinators.regexp Date: Mon, 8 Dec 2008 19:46:40 -0600 Subject: [PATCH 115/150] Remove eval dependency from unicode.syntax --- basis/unicode/syntax/syntax.factor | 4 ++-- core/strings/parser/parser-tests.factor | 4 ++++ core/strings/parser/parser.factor | 12 ++++++++++++ 3 files changed, 18 insertions(+), 2 deletions(-) create mode 100644 core/strings/parser/parser-tests.factor diff --git a/basis/unicode/syntax/syntax.factor b/basis/unicode/syntax/syntax.factor index bf4610ab0d..b7ac022d0e 100644 --- a/basis/unicode/syntax/syntax.factor +++ b/basis/unicode/syntax/syntax.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: unicode.data kernel math sequences parser lexer bit-arrays namespaces make sequences.private arrays quotations -assocs classes.predicate math.order eval ; +assocs classes.predicate math.order strings.parser ; IN: unicode.syntax ! Character classes (categories) @@ -26,7 +26,7 @@ IN: unicode.syntax categories [ swap member? ] with map >bit-array ; : as-string ( strings -- bit-array ) - concat "\"" tuck 3append eval ; + concat unescape-string ; : [category] ( categories -- quot ) [ diff --git a/core/strings/parser/parser-tests.factor b/core/strings/parser/parser-tests.factor new file mode 100644 index 0000000000..80f649c204 --- /dev/null +++ b/core/strings/parser/parser-tests.factor @@ -0,0 +1,4 @@ +IN: strings.parser.tests +USING: strings.parser tools.test ; + +[ "Hello\n\rworld" ] [ "Hello\\n\\rworld" unescape-string ] unit-test diff --git a/core/strings/parser/parser.factor b/core/strings/parser/parser.factor index cfe5d1a90a..4062e16e3d 100644 --- a/core/strings/parser/parser.factor +++ b/core/strings/parser/parser.factor @@ -58,3 +58,15 @@ name>char-hook global [ lexer get [ [ swap tail-slice (parse-string) ] "" make swap ] change-lexer-column ; + +: (unescape-string) ( str -- str' ) + dup [ CHAR: \\ = ] find [ + cut-slice [ % ] dip rest-slice + next-escape [ , ] dip + (unescape-string) + ] [ + drop % + ] if ; + +: unescape-string ( str -- str' ) + [ (unescape-string) ] "" make ; From 5bfa17d9627dc49ce0e454c0b1ecf68b96ea4c43 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Dec 2008 20:04:13 -0600 Subject: [PATCH 116/150] Split off error. methods into sub-vocabs in a few places --- basis/http/client/client.factor | 16 +++++-------- basis/http/client/debugger/debugger.factor | 13 +++++++++++ basis/http/http.factor | 8 +++---- basis/peg/debugger/debugger.factor | 12 ++++++++++ basis/peg/ebnf/ebnf.factor | 11 ++++----- basis/peg/peg.factor | 26 +++++++++------------- basis/urls/prettyprint/prettyprint.factor | 6 +++++ basis/urls/urls.factor | 9 +++++--- 8 files changed, 61 insertions(+), 40 deletions(-) create mode 100644 basis/http/client/debugger/debugger.factor create mode 100644 basis/peg/debugger/debugger.factor create mode 100644 basis/urls/prettyprint/prettyprint.factor diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index 9260f15a7b..119fa23567 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -3,14 +3,14 @@ USING: accessors assocs kernel math math.parser namespaces make sequences io io.sockets io.streams.string io.files io.timeouts strings splitting calendar continuations accessors vectors -math.order hashtables byte-arrays prettyprint destructors +math.order hashtables byte-arrays destructors io.encodings io.encodings.string io.encodings.ascii io.encodings.8-bit io.encodings.binary io.streams.duplex -fry debugger summary ascii urls urls.encoding present +fry ascii urls urls.encoding present http http.parsers ; IN: http.client @@ -84,10 +84,6 @@ M: f >post-data ; ERROR: too-many-redirects ; -M: too-many-redirects summary - drop - [ "Redirection limit of " % max-redirects # " exceeded" % ] "" make ; - ERROR: download-failed response ; -M: download-failed error. - "HTTP request failed:" print nl - response>> . ; - : check-response ( response -- response ) dup code>> success? [ download-failed ] unless ; @@ -203,3 +195,7 @@ M: download-failed error. : http-post ( post-data url -- response data ) http-request ; + +USING: vocabs vocabs.loader ; + +"debugger" vocab [ "http.client.debugger" require ] when diff --git a/basis/http/client/debugger/debugger.factor b/basis/http/client/debugger/debugger.factor new file mode 100644 index 0000000000..413ae7bd85 --- /dev/null +++ b/basis/http/client/debugger/debugger.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel summary debugger io make math.parser +prettyprint http.client accessors ; +IN: http.client.debugger + +M: too-many-redirects summary + drop + [ "Redirection limit of " % max-redirects # " exceeded" % ] "" make ; + +M: download-failed error. + "HTTP request failed:" print nl + response>> . ; diff --git a/basis/http/http.factor b/basis/http/http.factor index d006c86462..bbb0335ae4 100644 --- a/basis/http/http.factor +++ b/basis/http/http.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel combinators math namespaces make -assocs sequences splitting sorting sets debugger -strings vectors hashtables quotations arrays byte-arrays -math.parser calendar calendar.format present urls +USING: accessors kernel combinators math namespaces make assocs +sequences splitting sorting sets strings vectors hashtables +quotations arrays byte-arrays math.parser calendar +calendar.format present urls io io.encodings io.encodings.iana io.encodings.binary io.encodings.8-bit diff --git a/basis/peg/debugger/debugger.factor b/basis/peg/debugger/debugger.factor new file mode 100644 index 0000000000..7e751b5110 --- /dev/null +++ b/basis/peg/debugger/debugger.factor @@ -0,0 +1,12 @@ +USING: io kernel accessors math.parser sequences prettyprint +debugger peg ; +IN: peg.debugger + +M: parse-error error. + "Peg parsing error at character position " write dup position>> number>string write + "." print "Expected " write messages>> [ " or " write ] [ write ] interleave nl ; + +M: parse-failed error. + "The " write dup word>> pprint " word could not parse the following input:" print nl + input>> . ; + diff --git a/basis/peg/ebnf/ebnf.factor b/basis/peg/ebnf/ebnf.factor index ccae0fec93..ca97886235 100644 --- a/basis/peg/ebnf/ebnf.factor +++ b/basis/peg/ebnf/ebnf.factor @@ -5,7 +5,7 @@ sequences quotations vectors namespaces make math assocs continuations peg peg.parsers unicode.categories multiline splitting accessors effects sequences.deep peg.search combinators.short-circuit lexer io.streams.string stack-checker -io prettyprint combinators parser ; +io combinators parser ; IN: peg.ebnf : rule ( name word -- parser ) @@ -458,16 +458,13 @@ M: ebnf-var build-locals ( code ast -- ) M: object build-locals ( code ast -- ) drop ; +ERROR: bad-effect quot effect ; + : check-action-effect ( quot -- quot ) dup infer { { [ dup (( a -- b )) effect<= ] [ drop ] } { [ dup (( -- b )) effect<= ] [ drop [ drop ] prepose ] } - [ - [ - "Bad effect: " write effect>string write - " for quotation " write pprint - ] with-string-writer throw - ] + [ bad-effect ] } cond ; M: ebnf-action (transform) ( ast -- parser ) diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor index 8a62365f53..3fc6fec8ed 100644 --- a/basis/peg/peg.factor +++ b/basis/peg/peg.factor @@ -1,14 +1,12 @@ ! Copyright (C) 2007, 2008 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences strings fry namespaces make math assocs -debugger io vectors arrays math.parser math.order -vectors combinators classes sets unicode.categories -compiler.units parser words quotations effects memoize accessors -locals effects splitting combinators.short-circuit generalizations ; +io vectors arrays math.parser math.order vectors combinators +classes sets unicode.categories compiler.units parser words +quotations effects memoize accessors locals effects splitting +combinators.short-circuit generalizations ; IN: peg -USE: prettyprint - TUPLE: parse-result remaining ast ; TUPLE: parse-error position messages ; TUPLE: parser peg compiled id ; @@ -19,10 +17,6 @@ M: parser hashcode* id>> hashcode* ; C: parse-result C: parse-error -M: parse-error error. - "Peg parsing error at character position " write dup position>> number>string write - "." print "Expected " write messages>> [ " or " write ] [ write ] interleave nl ; - SYMBOL: error-stack : (merge-errors) ( a b -- c ) @@ -238,8 +232,6 @@ TUPLE: peg-head rule-id involved-set eval-set ; nip ] if ; -USE: prettyprint - : apply-rule ( r p -- ast ) ! 2dup [ rule-id ] dip 2array "apply-rule: " write . 2dup recall [ @@ -624,10 +616,6 @@ PRIVATE> ERROR: parse-failed input word ; -M: parse-failed error. - "The " write dup word>> pprint " word could not parse the following input:" print nl - input>> . ; - : PEG: (:) [let | def [ ] word [ ] | @@ -643,3 +631,9 @@ M: parse-failed error. ] with-compilation-unit ] over push-all ] ; parsing + +USING: vocabs vocabs.loader ; + +"debugger" vocab [ + "peg.debugger" require +] when diff --git a/basis/urls/prettyprint/prettyprint.factor b/basis/urls/prettyprint/prettyprint.factor new file mode 100644 index 0000000000..59fb79e8d3 --- /dev/null +++ b/basis/urls/prettyprint/prettyprint.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel present prettyprint.custom prettyprint.backend urls ; +IN: urls.prettyprint + +M: url pprint* dup present "URL\" " "\"" pprint-string ; diff --git a/basis/urls/urls.factor b/basis/urls/urls.factor index 5f6d04a54f..d71ce4ef7b 100644 --- a/basis/urls/urls.factor +++ b/basis/urls/urls.factor @@ -4,8 +4,7 @@ USING: kernel ascii combinators combinators.short-circuit sequences splitting fry namespaces make assocs arrays strings io.sockets io.encodings.string io.encodings.utf8 math math.parser accessors parser strings.parser lexer -prettyprint.backend prettyprint.custom hashtables present -peg.ebnf urls.encoding ; +hashtables present peg.ebnf urls.encoding ; IN: urls TUPLE: url protocol username password host port path query anchor ; @@ -182,4 +181,8 @@ PRIVATE> ! Literal syntax : URL" lexer get skip-blank parse-string >url parsed ; parsing -M: url pprint* dup present "URL\" " "\"" pprint-string ; +USING: vocabs vocabs.loader ; + +"prettyprint" vocab [ + "urls.prettyprint" require +] when From 1d57b0bc50951718190e46dbb86b65f51baa5532 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Dec 2008 20:06:44 -0600 Subject: [PATCH 117/150] Fix load errors --- basis/io/encodings/utf16n/utf16n.factor | 2 +- basis/io/streams/limited/limited.factor | 2 +- basis/tools/deploy/deploy-tests.factor | 6 +++--- extra/multi-methods/multi-methods.factor | 7 ++++--- 4 files changed, 9 insertions(+), 8 deletions(-) diff --git a/basis/io/encodings/utf16n/utf16n.factor b/basis/io/encodings/utf16n/utf16n.factor index 2fae7bd66a..cc6e7e2baa 100644 --- a/basis/io/encodings/utf16n/utf16n.factor +++ b/basis/io/encodings/utf16n/utf16n.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types io.encodings io.encodings.utf16 ; +USING: alien.c-types io.encodings io.encodings.utf16 kernel ; IN: io.encodings.utf16n ! Native-order UTF-16 diff --git a/basis/io/streams/limited/limited.factor b/basis/io/streams/limited/limited.factor index e89b31a884..ecc49923de 100644 --- a/basis/io/streams/limited/limited.factor +++ b/basis/io/streams/limited/limited.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: kernel math io io.encodings destructors accessors -sequences namespaces ; +sequences namespaces byte-vectors ; IN: io.streams.limited TUPLE: limited-stream stream count limit ; diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index af065c9bf6..71dc746fb5 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -1,8 +1,8 @@ IN: tools.deploy.tests USING: tools.test system io.files kernel tools.deploy.config -tools.deploy.backend math sequences io.launcher arrays -namespaces continuations layouts accessors io.encodings.ascii -urls math.parser ; +tools.deploy.config.editor tools.deploy.backend math sequences +io.launcher arrays namespaces continuations layouts accessors +io.encodings.ascii urls math.parser ; : shake-and-bake ( vocab -- ) [ "test.image" temp-file delete-file ] ignore-errors diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index 14062b15db..cfdc28bb3d 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -2,9 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel math sequences vectors classes classes.algebra combinators arrays words assocs parser namespaces make -definitions prettyprint prettyprint.backend quotations -generalizations debugger io compiler.units kernel.private -effects accessors hashtables sorting shuffle math.order sets ; +definitions prettyprint prettyprint.backend prettyprint.custom +quotations generalizations debugger io compiler.units +kernel.private effects accessors hashtables sorting shuffle +math.order sets ; IN: multi-methods ! PART I: Converting hook specializers From 7f93d335a656611cc656ebe6fd8bf576a82453f3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 8 Dec 2008 20:10:52 -0600 Subject: [PATCH 118/150] fix bug in io.paths, add io.paths.windows --- extra/io/paths/paths.factor | 23 ++++++++++++++++------- extra/io/paths/windows/authors.txt | 1 + extra/io/paths/windows/tags.txt | 1 + extra/io/paths/windows/windows.factor | 13 +++++++++++++ 4 files changed, 31 insertions(+), 7 deletions(-) create mode 100644 extra/io/paths/windows/authors.txt create mode 100644 extra/io/paths/windows/tags.txt create mode 100644 extra/io/paths/windows/windows.factor diff --git a/extra/io/paths/paths.factor b/extra/io/paths/paths.factor index 8237e59a1b..75d08b60f8 100755 --- a/extra/io/paths/paths.factor +++ b/extra/io/paths/paths.factor @@ -1,11 +1,13 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: io.files kernel sequences accessors -dlists deques arrays ; +USING: accessors arrays deques dlists io.files io.paths.private +kernel sequences system vocabs.loader fry continuations ; IN: io.paths TUPLE: directory-iterator path bfs queue ; + + +: find-file ( path bfs? quot: ( obj -- ? ) -- path/f ) [ ] dip [ keep and ] curry iterate-directory ; inline -: each-file ( path bfs? quot -- ) +: each-file ( path bfs? quot: ( obj -- ? ) -- ) [ ] dip [ f ] compose iterate-directory drop ; inline -: find-all-files ( path bfs? quot -- paths ) +: find-all-files ( path bfs? quot: ( obj -- ? ) -- paths ) [ ] dip pusher [ [ f ] compose iterate-directory drop ] dip ; inline : recursive-directory ( path bfs? -- paths ) [ ] accumulator [ each-file ] dip ; + +: find-in-directories ( directories bfs? quot -- path' ) + '[ _ _ find-file ] attempt-all ; inline + +os windows? [ "io.paths.windows" require ] when diff --git a/extra/io/paths/windows/authors.txt b/extra/io/paths/windows/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/io/paths/windows/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/io/paths/windows/tags.txt b/extra/io/paths/windows/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/io/paths/windows/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/io/paths/windows/windows.factor b/extra/io/paths/windows/windows.factor new file mode 100644 index 0000000000..b4858aaef8 --- /dev/null +++ b/extra/io/paths/windows/windows.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays continuations fry io.files io.paths +kernel windows.shell32 sequences ; +IN: io.paths.windows + +: program-files-directories ( -- array ) + program-files program-files-x86 2array ; inline + +: find-in-program-files ( base-directory bfs? quot -- path ) + [ + [ program-files-directories ] dip '[ _ append-path ] map + ] 2dip find-in-directories ; inline From 44e582bbebe92c194a74f0b761c4e3432a20d473 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 8 Dec 2008 20:11:24 -0600 Subject: [PATCH 119/150] update all editors for windows 64 to look in "program files" and "program files (x86)" --- basis/editors/editpadlite/authors.txt | 2 ++ .../editpadlite/editpadlite-docs.factor | 7 ++++ basis/editors/editpadlite/editpadlite.factor | 16 +++++++++ basis/editors/editpadlite/summary.txt | 1 + basis/editors/editpadlite/tags.txt | 1 + .../editors/editpadpro/editpadpro-docs.factor | 7 ++-- basis/editors/editpadpro/editpadpro.factor | 9 +++-- basis/editors/editplus/editplus.factor | 4 +-- basis/editors/emeditor/emeditor.factor | 7 ++-- basis/editors/etexteditor/etexteditor.factor | 4 +-- basis/editors/gvim/windows/windows.factor | 5 ++- basis/editors/notepad2/notepad2.factor | 8 ++--- basis/editors/notepadpp/notepadpp.factor | 6 ++-- basis/editors/scite/scite.factor | 35 +++++++------------ basis/editors/scite/summary.txt | 2 +- basis/editors/ted-notepad/ted-notepad.factor | 9 ++--- basis/editors/textedit/textedit.factor | 3 -- basis/editors/ultraedit/ultraedit.factor | 5 ++- basis/editors/wordpad/wordpad.factor | 10 +++--- 19 files changed, 77 insertions(+), 64 deletions(-) create mode 100644 basis/editors/editpadlite/authors.txt create mode 100644 basis/editors/editpadlite/editpadlite-docs.factor create mode 100644 basis/editors/editpadlite/editpadlite.factor create mode 100644 basis/editors/editpadlite/summary.txt create mode 100644 basis/editors/editpadlite/tags.txt diff --git a/basis/editors/editpadlite/authors.txt b/basis/editors/editpadlite/authors.txt new file mode 100644 index 0000000000..aa43d6ea12 --- /dev/null +++ b/basis/editors/editpadlite/authors.txt @@ -0,0 +1,2 @@ +Ryan Murphy +Doug Coleman diff --git a/basis/editors/editpadlite/editpadlite-docs.factor b/basis/editors/editpadlite/editpadlite-docs.factor new file mode 100644 index 0000000000..4f0c8f800d --- /dev/null +++ b/basis/editors/editpadlite/editpadlite-docs.factor @@ -0,0 +1,7 @@ +USING: help.syntax help.markup ; +IN: editors.editpadpro + +ARTICLE: "editors.editpadpro" "EditPad Pro support" +"EditPadPro text editor integration on Windows. Be sure to put EditPadPro in your system path so that it will be found. Windows only." ; + +ABOUT: "editors.editpadpro" diff --git a/basis/editors/editpadlite/editpadlite.factor b/basis/editors/editpadlite/editpadlite.factor new file mode 100644 index 0000000000..c002c2fa75 --- /dev/null +++ b/basis/editors/editpadlite/editpadlite.factor @@ -0,0 +1,16 @@ +USING: definitions kernel parser words sequences math.parser +namespaces editors io.launcher windows.shell32 io.files +io.paths.windows strings unicode.case make ; +IN: editors.editpadlite + +: editpadlite-path ( -- path ) + \ editpadlite-path get-global [ + "JGsoft" t [ >lower "editpadlite.exe" tail? ] find-in-program-files + ] unless* ; + +: editpadlite ( file line -- ) + [ + editpadlite-path , drop , + ] { } make run-detached drop ; + +[ editpadlite ] edit-hook set-global diff --git a/basis/editors/editpadlite/summary.txt b/basis/editors/editpadlite/summary.txt new file mode 100644 index 0000000000..445e15f75d --- /dev/null +++ b/basis/editors/editpadlite/summary.txt @@ -0,0 +1 @@ +EditPadLite editor integration diff --git a/basis/editors/editpadlite/tags.txt b/basis/editors/editpadlite/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/editpadlite/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/editors/editpadpro/editpadpro-docs.factor b/basis/editors/editpadpro/editpadpro-docs.factor index f3484917cb..4f0c8f800d 100644 --- a/basis/editors/editpadpro/editpadpro-docs.factor +++ b/basis/editors/editpadpro/editpadpro-docs.factor @@ -1,6 +1,7 @@ USING: help.syntax help.markup ; +IN: editors.editpadpro -ARTICLE: "editpadpro" "EditPad Pro support" -"Just load this module and you will be able to edit documentation with EditPadPro. Be sure to put EditPadPro in your system path so that it will be found. Windows only." ; +ARTICLE: "editors.editpadpro" "EditPad Pro support" +"EditPadPro text editor integration on Windows. Be sure to put EditPadPro in your system path so that it will be found. Windows only." ; -ABOUT: "editpadpro" \ No newline at end of file +ABOUT: "editors.editpadpro" diff --git a/basis/editors/editpadpro/editpadpro.factor b/basis/editors/editpadpro/editpadpro.factor index 09f59f0916..2a7f92f932 100644 --- a/basis/editors/editpadpro/editpadpro.factor +++ b/basis/editors/editpadpro/editpadpro.factor @@ -1,17 +1,16 @@ USING: definitions kernel parser words sequences math.parser namespaces editors io.launcher windows.shell32 io.files -io.paths strings unicode.case make ; +io.paths.windows strings unicode.case make ; IN: editors.editpadpro -: editpadpro-path +: editpadpro-path ( -- path ) \ editpadpro-path get-global [ - program-files "JGsoft" append-path - t [ >lower "editpadpro.exe" tail? ] find-file + "JGsoft" t [ >lower "editpadpro.exe" tail? ] find-in-program-files ] unless* ; : editpadpro ( file line -- ) [ - editpadpro-path , "/l" swap number>string append , , + editpadpro-path , number>string "/l" prepend , , ] { } make run-detached drop ; [ editpadpro ] edit-hook set-global diff --git a/basis/editors/editplus/editplus.factor b/basis/editors/editplus/editplus.factor index 8af036f290..9fa477f51a 100644 --- a/basis/editors/editplus/editplus.factor +++ b/basis/editors/editplus/editplus.factor @@ -1,10 +1,10 @@ USING: editors io.files io.launcher kernel math.parser -namespaces sequences windows.shell32 make ; +namespaces sequences windows.shell32 make io.paths.windows ; IN: editors.editplus : editplus-path ( -- path ) \ editplus-path get-global [ - program-files "\\EditPlus 2\\editplus.exe" append-path + "EditPlus 2" t [ "editplus.exe" tail? ] find-in-program-files ] unless* ; : editplus ( file line -- ) diff --git a/basis/editors/emeditor/emeditor.factor b/basis/editors/emeditor/emeditor.factor index 9aec22eed1..fc3deae670 100644 --- a/basis/editors/emeditor/emeditor.factor +++ b/basis/editors/emeditor/emeditor.factor @@ -1,11 +1,10 @@ -USING: editors hardware-info.windows io.files io.launcher -kernel math.parser namespaces sequences windows.shell32 -make ; +USING: editors io.files io.launcher kernel math.parser +namespaces sequences windows.shell32 make io.paths.windows ; IN: editors.emeditor : emeditor-path ( -- path ) \ emeditor-path get-global [ - program-files "\\EmEditor\\EmEditor.exe" append-path + "EmEditor" t [ "EmEditor.exe" tail? ] find-in-program-files ] unless* ; : emeditor ( file line -- ) diff --git a/basis/editors/etexteditor/etexteditor.factor b/basis/editors/etexteditor/etexteditor.factor index 316bd24cfa..c4b3ad35c1 100755 --- a/basis/editors/etexteditor/etexteditor.factor +++ b/basis/editors/etexteditor/etexteditor.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2008 Kibleur Christophe. ! See http://factorcode.org/license.txt for BSD license. USING: editors io.files io.launcher kernel math.parser -namespaces sequences windows.shell32 make ; +namespaces sequences windows.shell32 io.paths.windows make ; IN: editors.etexteditor : etexteditor-path ( -- str ) \ etexteditor-path get-global [ - program-files "e\\e.exe" append-path + "e" t [ "e.exe" tail? ] find-in-program-files ] unless* ; : etexteditor ( file line -- ) diff --git a/basis/editors/gvim/windows/windows.factor b/basis/editors/gvim/windows/windows.factor index 8c4e1aaacb..2f733f3c2f 100644 --- a/basis/editors/gvim/windows/windows.factor +++ b/basis/editors/gvim/windows/windows.factor @@ -1,9 +1,8 @@ USING: editors.gvim io.files io.windows kernel namespaces -sequences windows.shell32 io.paths system ; +sequences windows.shell32 io.paths.windows system ; IN: editors.gvim.windows M: windows gvim-path \ gvim-path get-global [ - program-files "vim" append-path - t [ "gvim.exe" tail? ] find-file + "vim" t [ "gvim.exe" tail? ] find-in-program-files ] unless* ; diff --git a/basis/editors/notepad2/notepad2.factor b/basis/editors/notepad2/notepad2.factor index 4d333e45dd..e22de4f68d 100644 --- a/basis/editors/notepad2/notepad2.factor +++ b/basis/editors/notepad2/notepad2.factor @@ -2,10 +2,10 @@ USING: editors io.files io.launcher kernel math.parser namespaces sequences windows.shell32 make ; IN: editors.notepad2 -: notepad2-path ( -- str ) +: notepad2-path ( -- path ) \ notepad2-path get-global [ - program-files "C:\\Windows\\system32\\notepad.exe" append-path - ] unless* ; + "C:\\Windows\\system32\\notepad.exe" + ] unless* ; : notepad2 ( file line -- ) [ @@ -13,4 +13,4 @@ IN: editors.notepad2 "/g" , number>string , , ] { } make run-detached drop ; -[ notepad2 ] edit-hook set-global \ No newline at end of file +[ notepad2 ] edit-hook set-global diff --git a/basis/editors/notepadpp/notepadpp.factor b/basis/editors/notepadpp/notepadpp.factor index 540612aeec..d68008c2ca 100644 --- a/basis/editors/notepadpp/notepadpp.factor +++ b/basis/editors/notepadpp/notepadpp.factor @@ -1,10 +1,10 @@ USING: editors io.files io.launcher kernel math.parser -namespaces sequences windows.shell32 make ; +namespaces sequences io.paths.windows make ; IN: editors.notepadpp -: notepadpp-path +: notepadpp-path ( -- path ) \ notepadpp-path get-global [ - program-files "notepad++\\notepad++.exe" append-path + "notepad++" t [ "notepad++.exe" tail? ] find-in-program-files ] unless* ; : notepadpp ( file line -- ) diff --git a/basis/editors/scite/scite.factor b/basis/editors/scite/scite.factor index 10152f53d5..e0b48a3e72 100644 --- a/basis/editors/scite/scite.factor +++ b/basis/editors/scite/scite.factor @@ -1,34 +1,25 @@ -! Basic SciTE integration for Factor. -! -! By Clemens F. Hofreither, 2007. +! Copyright (C) 2007 Clemens F. Hofreither. +! See http://factorcode.org/license.txt for BSD license. ! clemens.hofreither@gmx.net -! -! In your .factor-rc or .factor-boot-rc, -! require this module and set the scite-path -! variable to point to your executable, -! if not on the path. -! -USING: io.files io.launcher kernel namespaces math -math.parser editors sequences windows.shell32 make ; +USING: io.files io.launcher kernel namespaces io.paths.windows +math math.parser editors sequences make unicode.case ; IN: editors.scite : scite-path ( -- path ) \ scite-path get-global [ - program-files "ScITE Source Code Editor\\SciTE.exe" append-path - dup exists? [ - drop program-files "wscite\\SciTE.exe" append-path - ] unless + "Scintilla Text Editor" t + [ >lower "scite.exe" tail? ] find-in-program-files ] unless* ; : scite-command ( file line -- cmd ) - swap - [ - scite-path , - , - "-goto:" swap number>string append , - ] { } make ; + swap + [ + scite-path , + , + number>string "-goto:" prepend , + ] { } make ; : scite-location ( file line -- ) - scite-command run-detached drop ; + scite-command run-detached drop ; [ scite-location ] edit-hook set-global diff --git a/basis/editors/scite/summary.txt b/basis/editors/scite/summary.txt index 1088ee7f5a..c5f9bb9a09 100644 --- a/basis/editors/scite/summary.txt +++ b/basis/editors/scite/summary.txt @@ -1 +1 @@ -SciTE editor integration +Scintilla text editor (SciTE) integration diff --git a/basis/editors/ted-notepad/ted-notepad.factor b/basis/editors/ted-notepad/ted-notepad.factor index b4135c92a0..994dc60ba3 100644 --- a/basis/editors/ted-notepad/ted-notepad.factor +++ b/basis/editors/ted-notepad/ted-notepad.factor @@ -1,15 +1,16 @@ USING: editors io.files io.launcher kernel math.parser -namespaces sequences windows.shell32 make ; +namespaces sequences io.paths.windows make ; IN: editors.ted-notepad -: ted-notepad-path +: ted-notepad-path ( -- path ) \ ted-notepad-path get-global [ - program-files "\\TED Notepad\\TedNPad.exe" append-path + "TED Notepad" t [ "TedNPad.exe" tail? ] find-in-program-files ] unless* ; : ted-notepad ( file line -- ) [ - ted-notepad-path , "/l" swap number>string append , , + ted-notepad-path , + number>string "/l" prepend , , ] { } make run-detached drop ; [ ted-notepad ] edit-hook set-global diff --git a/basis/editors/textedit/textedit.factor b/basis/editors/textedit/textedit.factor index 6942e24534..cccc94b539 100644 --- a/basis/editors/textedit/textedit.factor +++ b/basis/editors/textedit/textedit.factor @@ -1,6 +1,5 @@ USING: definitions io.launcher kernel math math.parser parser namespaces prettyprint editors make ; - IN: editors.textedit : textedit-location ( file line -- ) @@ -9,5 +8,3 @@ IN: editors.textedit try-process ; [ textedit-location ] edit-hook set-global - - diff --git a/basis/editors/ultraedit/ultraedit.factor b/basis/editors/ultraedit/ultraedit.factor index 7c9c41df7a..f1929ebf64 100644 --- a/basis/editors/ultraedit/ultraedit.factor +++ b/basis/editors/ultraedit/ultraedit.factor @@ -1,11 +1,10 @@ USING: editors io.files io.launcher kernel math.parser -namespaces sequences windows.shell32 wne ; +namespaces sequences io.paths.windows make ; IN: editors.ultraedit : ultraedit-path ( -- path ) \ ultraedit-path get-global [ - program-files - "IDM Computer Solutions\\UltraEdit-32\\uedit32.exe" append-path + "IDM Computer Solutions" t [ "uedit32.exe" tail? ] find-in-program-files ] unless* ; : ultraedit ( file line -- ) diff --git a/basis/editors/wordpad/wordpad.factor b/basis/editors/wordpad/wordpad.factor index 3f3dd6cab1..fa0f6852dd 100644 --- a/basis/editors/wordpad/wordpad.factor +++ b/basis/editors/wordpad/wordpad.factor @@ -1,14 +1,14 @@ -USING: editors hardware-info.windows io.launcher kernel -math.parser namespaces sequences windows.shell32 io.files -arrays ; +USING: editors io.launcher kernel io.paths.windows +math.parser namespaces sequences io.files arrays ; IN: editors.wordpad : wordpad-path ( -- path ) \ wordpad-path get [ - program-files "Windows NT\\Accessories\\wordpad.exe" append-path + "Windows NT\\Accessories" t + [ "wordpad.exe" tail? ] find-in-program-files ] unless* ; : wordpad ( file line -- ) - drop wordpad-path swap 2array dup . run-detached drop ; + drop wordpad-path swap 2array run-detached drop ; [ wordpad ] edit-hook set-global From e8027742cf17e6dc39dc86f873da99e91928ab2d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Dec 2008 20:13:04 -0600 Subject: [PATCH 120/150] Fix more load errors --- extra/bind-in/bind-in.factor | 2 +- extra/descriptive/descriptive.factor | 4 ++-- extra/reports/noise/noise.factor | 5 +++-- 3 files changed, 6 insertions(+), 5 deletions(-) diff --git a/extra/bind-in/bind-in.factor b/extra/bind-in/bind-in.factor index ab6ff19094..78c797df9b 100644 --- a/extra/bind-in/bind-in.factor +++ b/extra/bind-in/bind-in.factor @@ -1,5 +1,5 @@ -USING: kernel parser lexer locals.private ; +USING: kernel parser lexer locals.parser locals.types ; IN: bind-in diff --git a/extra/descriptive/descriptive.factor b/extra/descriptive/descriptive.factor index d02983d7fd..b1fdf2463e 100755 --- a/extra/descriptive/descriptive.factor +++ b/extra/descriptive/descriptive.factor @@ -1,5 +1,5 @@ -USING: words kernel sequences locals -locals.private accessors parser namespaces continuations +USING: words kernel sequences locals locals.parser +locals.definitions accessors parser namespaces continuations summary definitions generalizations arrays ; IN: descriptive diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor index 78ede32801..6a547ead24 100755 --- a/extra/reports/noise/noise.factor +++ b/extra/reports/noise/noise.factor @@ -2,8 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs math kernel shuffle generalizations words quotations arrays combinators sequences math.vectors -io.styles prettyprint vocabs sorting io generic locals.private -math.statistics math.order combinators.lib ; +io.styles prettyprint vocabs sorting io generic +math.statistics math.order combinators.lib locals.types +locals.definitions ; IN: reports.noise : badness ( word -- n ) From 833d9f9c0b858790b55128abe493bcf83a1650bf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Dec 2008 21:24:45 -0600 Subject: [PATCH 121/150] Fix quotation pooling --- basis/tools/deploy/shaker/shaker.factor | 4 ++-- vm/data_gc.c | 3 ++- vm/factor.c | 20 +------------------- vm/quotations.c | 23 +++++++++++++++++++++++ vm/quotations.h | 1 + 5 files changed, 29 insertions(+), 22 deletions(-) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 3c458f0a55..3d4944841d 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -394,11 +394,11 @@ SYMBOL: deploy-vocab deploy-vocab get vocab-main set-boot-quot* stripped-word-props stripped-globals strip-globals - strip-words compress-byte-arrays compress-quotations compress-strings - compress-wrappers ; + compress-wrappers + strip-words ; : (deploy) ( final-image vocab config -- ) #! Does the actual work of a deployment in the slave diff --git a/vm/data_gc.c b/vm/data_gc.c index 513a7c429c..6e15718b2d 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -985,7 +985,8 @@ void primitive_become(void) } gc(); - iterate_code_heap(relocate_code_block); + + compile_all_words(); } CELL find_all_words(void) diff --git a/vm/factor.c b/vm/factor.c index f198370ebe..2f78a797d4 100755 --- a/vm/factor.c +++ b/vm/factor.c @@ -44,25 +44,7 @@ void do_stage1_init(void) print_string("*** Stage 2 early init... "); fflush(stdout); - CELL words = find_all_words(); - - REGISTER_ROOT(words); - - CELL i; - CELL length = array_capacity(untag_object(words)); - for(i = 0; i < length; i++) - { - F_WORD *word = untag_word(array_nth(untag_array(words),i)); - REGISTER_UNTAGGED(word); - default_word_code(word,false); - UNREGISTER_UNTAGGED(word); - update_word_xt(word); - } - - UNREGISTER_ROOT(words); - - iterate_code_heap(relocate_code_block); - + compile_all_words(); userenv[STAGE2_ENV] = T; print_string("done\n"); diff --git a/vm/quotations.c b/vm/quotations.c index a187fecbbb..86952a32e8 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -522,3 +522,26 @@ void primitive_quotation_xt(void) F_QUOTATION *quot = untag_quotation(dpeek()); drepl(allot_cell((CELL)quot->xt)); } + +void compile_all_words(void) +{ + CELL words = find_all_words(); + + REGISTER_ROOT(words); + + CELL i; + CELL length = array_capacity(untag_object(words)); + for(i = 0; i < length; i++) + { + F_WORD *word = untag_word(array_nth(untag_array(words),i)); + REGISTER_UNTAGGED(word); + if(word->compiledp == F) + default_word_code(word,false); + UNREGISTER_UNTAGGED(word); + update_word_xt(word); + } + + UNREGISTER_ROOT(words); + + iterate_code_heap(relocate_code_block); +} diff --git a/vm/quotations.h b/vm/quotations.h index ff84977fd9..4c2c17bbb6 100755 --- a/vm/quotations.h +++ b/vm/quotations.h @@ -5,3 +5,4 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset); void primitive_array_to_quotation(void); void primitive_quotation_xt(void); void primitive_jit_compile(void); +void compile_all_words(void); From 14a54bb97a7a5182073be0d3fbe34e79d8b8fc8e Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 8 Dec 2008 21:30:10 -0600 Subject: [PATCH 122/150] trails: Un-processify trails --- extra/trails/trails.factor | 96 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 96 insertions(+) create mode 100644 extra/trails/trails.factor diff --git a/extra/trails/trails.factor b/extra/trails/trails.factor new file mode 100644 index 0000000000..cea5ece9f7 --- /dev/null +++ b/extra/trails/trails.factor @@ -0,0 +1,96 @@ + +USING: kernel accessors locals namespaces sequences sequences.lib threads + math math.order math.vectors + calendar + colors opengl ui ui.gadgets ui.gestures ui.render + circular + processing.shapes ; + +IN: trails + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! Example 33-15 from the Processing book + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! Return the mouse location relative to the current gadget + +: mouse ( -- point ) hand-loc get hand-gadget get screen-loc v- ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: point-list ( n -- seq ) [ drop { 0 0 } ] map ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: percent->radius ( percent -- radius ) neg 1 + 25 * 5 max ; + +: dot ( pos percent -- ) percent->radius circle ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: < gadget paused points ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +:: iterate-system ( GADGET -- ) + + ! Add a valid point if the mouse is in the gadget + ! Otherwise, add an "invisible" point + + hand-gadget get GADGET = + [ mouse GADGET points>> push-circular ] + [ { -10 -10 } GADGET points>> push-circular ] + if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +:: start-trails-thread ( GADGET -- ) + GADGET f >>paused drop + [ + [ + GADGET paused>> + [ f ] + [ GADGET iterate-system GADGET relayout-1 1 milliseconds sleep t ] + if + ] + loop + ] + in-thread ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +M: pref-dim* ( -- dim ) drop { 500 500 } ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +M:: draw-gadget* ( GADGET -- ) + origin get + [ + T{ rgba f 1 1 1 0.4 } \ fill-color set ! White, with some transparency + T{ rgba f 0 0 0 0 } \ stroke-color set ! no stroke + + black gl-clear + + GADGET points>> [ dot ] each-percent + ] + with-translation ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: trails-gadget ( -- ) + + new-gadget + + 300 point-list >>points + + t >>clipped? + + dup start-trails-thread ; + +: trails-window ( -- ) [ trails-gadget "Trails" open-window ] with-ui ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +MAIN: trails-window \ No newline at end of file From 971a6c89beac976ad8a90e7ff87df33133413c5c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 8 Dec 2008 21:31:41 -0600 Subject: [PATCH 123/150] move io.paths from extra to basis --- {extra => basis}/io/paths/authors.txt | 0 {extra => basis}/io/paths/paths.factor | 2 +- {extra => basis}/io/paths/windows/authors.txt | 0 {extra => basis}/io/paths/windows/tags.txt | 0 {extra => basis}/io/paths/windows/windows.factor | 0 5 files changed, 1 insertion(+), 1 deletion(-) rename {extra => basis}/io/paths/authors.txt (100%) rename {extra => basis}/io/paths/paths.factor (96%) rename {extra => basis}/io/paths/windows/authors.txt (100%) rename {extra => basis}/io/paths/windows/tags.txt (100%) rename {extra => basis}/io/paths/windows/windows.factor (100%) diff --git a/extra/io/paths/authors.txt b/basis/io/paths/authors.txt similarity index 100% rename from extra/io/paths/authors.txt rename to basis/io/paths/authors.txt diff --git a/extra/io/paths/paths.factor b/basis/io/paths/paths.factor similarity index 96% rename from extra/io/paths/paths.factor rename to basis/io/paths/paths.factor index 75d08b60f8..212ba9e396 100755 --- a/extra/io/paths/paths.factor +++ b/basis/io/paths/paths.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays deques dlists io.files io.paths.private +USING: accessors arrays deques dlists io.files kernel sequences system vocabs.loader fry continuations ; IN: io.paths diff --git a/extra/io/paths/windows/authors.txt b/basis/io/paths/windows/authors.txt similarity index 100% rename from extra/io/paths/windows/authors.txt rename to basis/io/paths/windows/authors.txt diff --git a/extra/io/paths/windows/tags.txt b/basis/io/paths/windows/tags.txt similarity index 100% rename from extra/io/paths/windows/tags.txt rename to basis/io/paths/windows/tags.txt diff --git a/extra/io/paths/windows/windows.factor b/basis/io/paths/windows/windows.factor similarity index 100% rename from extra/io/paths/windows/windows.factor rename to basis/io/paths/windows/windows.factor From 29bd77d04061158090b50ae9215298d4b3f903a6 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 8 Dec 2008 21:32:09 -0600 Subject: [PATCH 124/150] Remove old trails --- extra/processing/gallery/trails/trails.factor | 47 ------------------- 1 file changed, 47 deletions(-) delete mode 100644 extra/processing/gallery/trails/trails.factor diff --git a/extra/processing/gallery/trails/trails.factor b/extra/processing/gallery/trails/trails.factor deleted file mode 100644 index a5b2b7b02a..0000000000 --- a/extra/processing/gallery/trails/trails.factor +++ /dev/null @@ -1,47 +0,0 @@ - -USING: kernel arrays sequences math math.order qualified - sequences.lib circular processing ui newfx processing.shapes ; - -IN: processing.gallery.trails - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! Example 33-15 from the Processing book - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: point-list ( n -- seq ) [ drop 0 0 2array ] map ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: dot ( pos percent -- ) 1 swap - 25 * 5 max circle ; - -: step ( seq -- ) - - no-stroke - { 1 0.4 } fill - - 0 background - - mouse push-circular - [ dot ] - each-percent ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: go* ( -- ) - - 500 500 size* - - [ - 100 point-list - [ step ] - curry - draw - ] setup - - run ; - -: go ( -- ) [ go* ] with-ui ; - -MAIN: go From 101bc66b2b16d65fc16c576efafcf0e32b7f6553 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 8 Dec 2008 21:32:19 -0600 Subject: [PATCH 125/150] add a unit test to io.paths --- basis/io/paths/paths-tests.factor | 11 +++++++++++ 1 file changed, 11 insertions(+) create mode 100644 basis/io/paths/paths-tests.factor diff --git a/basis/io/paths/paths-tests.factor b/basis/io/paths/paths-tests.factor new file mode 100644 index 0000000000..01763ce5c0 --- /dev/null +++ b/basis/io/paths/paths-tests.factor @@ -0,0 +1,11 @@ +USING: io.paths kernel tools.test io.files.unique sequences +io.files namespaces sorting ; +IN: io.paths.tests + +[ t ] [ + [ + 10 [ "io.paths.test" "gogogo" make-unique-file* ] replicate + current-directory get t [ ] find-all-files + ] with-unique-directory + [ natural-sort ] bi@ = +] unit-test From 154bc260c637c0c3670ad061648fc99243fdb076 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 8 Dec 2008 21:32:36 -0600 Subject: [PATCH 126/150] remove io.files.unique.backend rename (make-unique-file) to touch-unique-file --- basis/io/files/unique/backend/backend.factor | 5 ---- basis/io/files/unique/unique.factor | 25 +++++++++++++------- basis/io/unix/files/unique/unique.factor | 4 ++-- basis/io/windows/files/unique/unique.factor | 8 +++---- 4 files changed, 22 insertions(+), 20 deletions(-) delete mode 100644 basis/io/files/unique/backend/backend.factor diff --git a/basis/io/files/unique/backend/backend.factor b/basis/io/files/unique/backend/backend.factor deleted file mode 100644 index 7b9809fa28..0000000000 --- a/basis/io/files/unique/backend/backend.factor +++ /dev/null @@ -1,5 +0,0 @@ -USING: io.backend ; -IN: io.files.unique.backend - -HOOK: (make-unique-file) io-backend ( path -- ) -HOOK: temporary-path io-backend ( -- path ) diff --git a/basis/io/files/unique/unique.factor b/basis/io/files/unique/unique.factor index ec89517bbc..66540fb48e 100644 --- a/basis/io/files/unique/unique.factor +++ b/basis/io/files/unique/unique.factor @@ -1,11 +1,13 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.bitwise math.parser -random sequences continuations namespaces -io.files io arrays io.files.unique.backend system -combinators vocabs.loader fry ; +USING: kernel math math.bitwise math.parser random sequences +continuations namespaces io.files io arrays system +combinators vocabs.loader fry io.backend ; IN: io.files.unique +HOOK: touch-unique-file io-backend ( path -- ) +HOOK: temporary-path io-backend ( -- path ) + SYMBOL: unique-length SYMBOL: unique-retries @@ -26,12 +28,17 @@ SYMBOL: unique-retries PRIVATE> +: (make-unique-file) ( path prefix suffix -- path ) + '[ + _ _ _ unique-length get random-name glue append-path + dup touch-unique-file + ] unique-retries get retry ; + : make-unique-file ( prefix suffix -- path ) - temporary-path -rot - [ - unique-length get random-name glue append-path - dup (make-unique-file) - ] 3curry unique-retries get retry ; + [ temporary-path ] 2dip (make-unique-file) ; + +: make-unique-file* ( prefix suffix -- path ) + [ current-directory get ] 2dip (make-unique-file) ; : with-unique-file ( prefix suffix quot: ( path -- ) -- ) [ make-unique-file ] dip [ delete-file ] bi ; inline diff --git a/basis/io/unix/files/unique/unique.factor b/basis/io/unix/files/unique/unique.factor index e47ac6a2e3..24dcdcb65a 100644 --- a/basis/io/unix/files/unique/unique.factor +++ b/basis/io/unix/files/unique/unique.factor @@ -1,13 +1,13 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: kernel io.ports io.unix.backend math.bitwise -unix io.files.unique.backend system ; +unix system io.files.unique ; IN: io.unix.files.unique : open-unique-flags ( -- flags ) { O_RDWR O_CREAT O_EXCL } flags ; -M: unix (make-unique-file) ( path -- ) +M: unix touch-unique-file ( path -- ) open-unique-flags file-mode open-file close-file ; M: unix temporary-path ( -- path ) "/tmp" ; diff --git a/basis/io/windows/files/unique/unique.factor b/basis/io/windows/files/unique/unique.factor index b1bf2bdc1c..ab99bf2cac 100644 --- a/basis/io/windows/files/unique/unique.factor +++ b/basis/io/windows/files/unique/unique.factor @@ -1,9 +1,9 @@ -USING: kernel system io.files.unique.backend -windows.kernel32 io.windows io.windows.files io.ports windows -destructors environment ; +USING: kernel system windows.kernel32 io.windows +io.windows.files io.ports windows destructors environment +io.files.unique ; IN: io.windows.files.unique -M: windows (make-unique-file) ( path -- ) +M: windows touch-unique-file ( path -- ) GENERIC_WRITE CREATE_NEW 0 open-file dispose ; M: windows temporary-path ( -- path ) From 4fccc7126d4bf478eaf76dde5025c5f8248a8526 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Dec 2008 21:49:26 -0600 Subject: [PATCH 127/150] Fix alien.strings docs --- basis/alien/strings/strings-docs.factor | 4 ---- 1 file changed, 4 deletions(-) diff --git a/basis/alien/strings/strings-docs.factor b/basis/alien/strings/strings-docs.factor index 3dc358336c..19c29e613e 100644 --- a/basis/alien/strings/strings-docs.factor +++ b/basis/alien/strings/strings-docs.factor @@ -31,10 +31,6 @@ HELP: string>symbol $nl "On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ; -HELP: utf16n -{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings of the type wchar_t*" } -{ $see-also "encodings-introduction" } ; - ARTICLE: "c-strings" "C strings" "C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors." $nl From 08d0035ac873e91c8c4d48325d2afe72061347bf Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 8 Dec 2008 21:53:42 -0600 Subject: [PATCH 128/150] document new unique word --- basis/io/files/unique/unique-docs.factor | 36 +++++++++++++++++++++--- 1 file changed, 32 insertions(+), 4 deletions(-) diff --git a/basis/io/files/unique/unique-docs.factor b/basis/io/files/unique/unique-docs.factor index 825eb212f1..bfde09dc48 100644 --- a/basis/io/files/unique/unique-docs.factor +++ b/basis/io/files/unique/unique-docs.factor @@ -2,12 +2,40 @@ USING: help.markup help.syntax io io.ports kernel math io.files.unique.private math.parser io.files ; IN: io.files.unique +HELP: temporary-path +{ $values + { "path" "a pathname string" } +} +{ $description "A hook that returns the path of the temporary directory in a platform-specific way. Does not guarantee that path is writable by your user." } ; + +HELP: touch-unique-file +{ $values + { "path" "a pathname string" } +} +{ $description "Creates a unique file in a platform-specific way. The file is guaranteed not to exist and is openable by your user." } ; + +HELP: unique-length +{ $description "A symbol storing the number of random characters inserted between the prefix and suffix of a random file name." } ; + +HELP: unique-retries +{ $description "The number of times to try creating a unique file in case of a name collision. The odds of a name collision are extremely low with a sufficient " { $link unique-length } "." } ; + +{ unique-length unique-retries } related-words + HELP: make-unique-file ( prefix suffix -- path ) { $values { "prefix" "a string" } { "suffix" "a string" } { "path" "a pathname string" } } { $description "Creates a file that is guaranteed not to exist in a platform-specific temporary directory. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." } -{ $errors "Throws an error if a new unique file cannot be created after a number of tries. The most likely error is incorrect directory permissions on the temporary directory." } -{ $see-also with-unique-file } ; +{ $errors "Throws an error if a new unique file cannot be created after a number of tries. The most likely error is incorrect directory permissions on the temporary directory." } ; + +HELP: make-unique-file* +{ $values + { "prefix" null } { "suffix" null } + { "path" "a pathname string" } +} +{ $description "Creates a file that is guaranteed not to exist in the directory in the " { $link current-directory } " variable. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." } ; + +{ make-unique-file make-unique-file* with-unique-file } related-words HELP: with-unique-file ( prefix suffix quot: ( path -- ) -- ) { $values { "prefix" "a string" } { "suffix" "a string" } @@ -18,8 +46,7 @@ HELP: with-unique-file ( prefix suffix quot: ( path -- ) -- ) HELP: make-unique-directory ( -- path ) { $values { "path" "a pathname string" } } { $description "Creates a directory that is guaranteed not to exist in a platform-specific temporary directory and returns the full pathname." } -{ $errors "Throws an error if the directory cannot be created after a number of tries. The most likely error is incorrect directory permissions on the temporary directory." } -{ $see-also with-unique-directory } ; +{ $errors "Throws an error if the directory cannot be created after a number of tries. The most likely error is incorrect directory permissions on the temporary directory." } ; HELP: with-unique-directory ( quot -- ) { $values { "quot" "a quotation" } } @@ -30,6 +57,7 @@ ARTICLE: "io.files.unique" "Temporary files" "The " { $vocab-link "io.files.unique" } " vocabulary implements cross-platform temporary file creation in a high-level and secure way." $nl "Files:" { $subsection make-unique-file } +{ $subsection make-unique-file* } { $subsection with-unique-file } "Directories:" { $subsection make-unique-directory } From b154b21aaa209f9387eafbf29d7d9b7299f50321 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Dec 2008 23:37:18 -0600 Subject: [PATCH 129/150] Add new until combinator, and a new do word which acts like a modifier: do while, do until for loops which iterate at least once --- basis/bit-arrays/bit-arrays.factor | 4 +- .../combinators/combinators.factor | 2 +- basis/io/encodings/utf16n/utf16n-docs.factor | 6 +++ basis/io/unix/launcher/launcher.factor | 5 +-- basis/tools/walker/walker.factor | 4 +- core/bootstrap/primitives.factor | 2 +- core/combinators/combinators-docs.factor | 2 - core/kernel/kernel-docs.factor | 45 +++++++++++++++---- core/kernel/kernel.factor | 21 +++++---- core/math/integers/integers.factor | 2 +- core/memory/memory.factor | 4 +- core/slots/slots.factor | 2 +- 12 files changed, 67 insertions(+), 32 deletions(-) create mode 100644 basis/io/encodings/utf16n/utf16n-docs.factor diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor index d5e94f0238..d407f0b84d 100644 --- a/basis/bit-arrays/bit-arrays.factor +++ b/basis/bit-arrays/bit-arrays.factor @@ -73,11 +73,11 @@ M: bit-array byte-length length 7 + -3 shift ; :: integer>bit-array ( n -- bit-array ) n zero? [ 0 ] [ [let | out [ n log2 1+ ] i! [ 0 ] n'! [ n ] | - [ n' zero? not ] [ + [ n' zero? ] [ n' out underlying>> i set-alien-unsigned-1 n' -8 shift n'! i 1+ i! - ] [ ] while + ] [ ] until out ] ] if ; diff --git a/basis/concurrency/combinators/combinators.factor b/basis/concurrency/combinators/combinators.factor index 4608faf79b..932605fc36 100644 --- a/basis/concurrency/combinators/combinators.factor +++ b/basis/concurrency/combinators/combinators.factor @@ -22,7 +22,7 @@ PRIVATE> ] (parallel-each) ; inline : parallel-filter ( seq quot -- newseq ) - over [ pusher [ each ] dip ] dip like ; inline + over [ pusher [ parallel-each ] dip ] dip like ; inline fixnum ] bootstrap-max-array-capacity [ fixnum-bitand ] curry append +[ >fixnum ] bootstrap-max-array-capacity [ fixnum-bitand ] curry append "coercer" set-word-prop ! Catch-all class for providing a default method. diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index 8d1d9f0d2a..a26c2fbe5d 100644 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -12,8 +12,6 @@ ARTICLE: "combinators-quot" "Quotation construction utilities" ARTICLE: "combinators" "Additional combinators" "The " { $vocab-link "combinators" } " vocabulary provides a few useful combinators." $nl -"A looping combinator:" -{ $subsection while } "Generalization of " { $link bi } " and " { $link tri } ":" { $subsection cleave } "Generalization of " { $link 2bi } " and " { $link 2tri } ":" diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 01ef8d480d..1404491d10 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -603,15 +603,15 @@ HELP: 3dip HELP: while { $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } } -{ $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "body" } " is called. After iteration stops, " { $snippet "tail" } " is called." } -{ $notes "In most cases, tail recursion should be used, because it is simpler both in terms of implementation and conceptually. However in some cases this combinator expresses intent better and should be used." -$nl -"Strictly speaking, the " { $snippet "tail" } " is not necessary, since the following are equivalent:" -{ $code - "[ P ] [ Q ] [ T ] while" - "[ P ] [ Q ] [ ] while T" -} -"However, depending on the stack effects of " { $snippet "pred" } " and " { $snippet "quot" } ", the " { $snippet "tail" } " quotation might need to be non-empty in order to balance out the stack effect of branches for stack effect inference." } ; +{ $description "Calls " { $snippet "body" } " until " { $snippet "pred" } " returns " { $link f } "." } ; + +HELP: until +{ $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } } +{ $description "Calls " { $snippet "body" } " until " { $snippet "pred" } " returns " { $link t } "." } ; + +HELP: do +{ $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } } +{ $description "Executes one iteration of a " { $link while } " or " { $link until } " loop." } ; HELP: loop { $values @@ -627,6 +627,26 @@ HELP: loop "3\n10\n6\n2\n9\n5\n1\n8\n4\n0\n7" } } ; +ARTICLE: "looping-combinators" "Looping combinators" +"In most cases, loops should be written using high-level combinators (such as " { $link "sequences-combinators" } ") or tail recursion. However, sometimes, the best way to express intent is with a loop." +{ $subsection while } +{ $subsection until } +"The above two combinators take a " { $snippet "tail" } " quotation. Strictly speaking, the " { $snippet "tail" } " is not necessary, since the following are equivalent:" +{ $code + "[ P ] [ Q ] [ T ] while" + "[ P ] [ Q ] [ ] while T" +} +"However, depending on the stack effects of " { $snippet "pred" } " and " { $snippet "quot" } ", the " { $snippet "tail" } " quotation might need to be non-empty in order to balance out the stack effect of branches for stack effect inference." +$nl +"To execute one iteration of a loop, use the following word:" +{ $subsection do } +"This word is intended as a modifier. The normal " { $link while } " loop never executes the body if the predicate returns first on the first iteration. To ensure the body executes at least once, use " { $link do } ":" +{ $code + "[ P ] [ Q ] [ T ] do while" +} +"A simpler looping combinator which executes a single quotation until it returns " { $link f } ":" +{ $subsection loop } ; + HELP: assert { $values { "got" "the obtained value" } { "expect" "the expected value" } } { $description "Throws an " { $link assert } " error." } @@ -899,13 +919,20 @@ ARTICLE: "dataflow" "Data and control flow" { $subsection "booleans" } { $subsection "shuffle-words" } "A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input." +$nl +"Data flow combinators:" { $subsection "slip-keep-combinators" } { $subsection "cleave-combinators" } { $subsection "spread-combinators" } { $subsection "apply-combinators" } +"Control flow combinators:" { $subsection "conditionals" } +{ $subsection "looping-combinators" } +"Additional combinators:" { $subsection "compositional-combinators" } { $subsection "combinators" } +"More combinators are defined for working on data structures, such as " { $link "sequences-combinators" } " and " { $link "assocs-combinators" } "." +$nl "Advanced topics:" { $subsection "assertions" } { $subsection "implementing-combinators" } diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 564600d322..d4df6fa407 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -129,14 +129,6 @@ DEFER: if : 2bi@ ( w x y z quot -- ) dup 2bi* ; inline -: loop ( pred: ( -- ? ) -- ) - dup slip swap [ loop ] [ drop ] if ; inline recursive - -: while ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- ) - [ dup slip ] 2dip roll - [ [ tuck 2slip ] dip while ] - [ 2nip call ] if ; inline recursive - ! Object protocol GENERIC: hashcode* ( depth obj -- code ) @@ -202,6 +194,19 @@ GENERIC: boa ( ... class -- tuple ) : most ( x y quot -- z ) [ 2dup ] dip call [ drop ] [ nip ] if ; inline +! Loops +: loop ( pred: ( -- ? ) -- ) + dup slip swap [ loop ] [ drop ] if ; inline recursive + +: do ( pred body tail -- pred body tail ) + over 3dip ; inline + +: while ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- ) + [ pick 3dip [ do while ] 3curry ] keep if ; inline recursive + +: until ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- ) + [ [ not ] compose ] 2dip while ; inline + ! Error handling -- defined early so that other files can ! throw errors before continuations are loaded : throw ( error -- * ) 5 getenv [ die ] or 1 (throw) ; diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index b229ea175d..6ed945216e 100644 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -41,7 +41,7 @@ M: fixnum bitnot fixnum-bitnot ; M: fixnum bit? neg shift 1 bitand 0 > ; : fixnum-log2 ( x -- n ) - 0 swap [ dup 1 eq? not ] [ [ 1+ ] [ 2/ ] bi* ] [ ] while drop ; + 0 swap [ dup 1 eq? ] [ [ 1+ ] [ 2/ ] bi* ] [ ] until drop ; M: fixnum (log2) fixnum-log2 ; diff --git a/core/memory/memory.factor b/core/memory/memory.factor index 42527371f2..b67f7c94e8 100644 --- a/core/memory/memory.factor +++ b/core/memory/memory.factor @@ -4,7 +4,9 @@ USING: kernel continuations sequences vectors arrays system math ; IN: memory : (each-object) ( quot: ( obj -- ) -- ) - [ next-object dup ] swap [ drop ] while ; inline + next-object dup [ + swap [ call ] keep (each-object) + ] [ 2drop ] if ; inline recursive : each-object ( quot -- ) begin-scan [ (each-object) ] [ end-scan ] [ ] cleanup ; inline diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 187db02c5c..438e604e78 100644 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -199,7 +199,7 @@ M: array make-slot swap peel-off-name peel-off-class - [ dup empty? not ] [ peel-off-attributes ] [ ] while drop + [ dup empty? ] [ peel-off-attributes ] [ ] until drop check-initial-value ; M: slot-spec make-slot From 7c1c97470f32b9efb26adbbd3501ce288a853b6a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Dec 2008 23:52:46 -0600 Subject: [PATCH 130/150] tuple-class-unchanged? was bogusly returning f during bootstrap for classes without a superclass --- core/classes/tuple/tuple.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 9d748d665d..d9464399a9 100644 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -252,7 +252,7 @@ M: tuple-class update-class : tuple-class-unchanged? ( class superclass slots -- ? ) [ over ] dip - [ [ superclass ] dip = ] + [ [ superclass ] [ bootstrap-word ] bi* = ] [ [ "slots" word-prop ] dip = ] 2bi* and ; : valid-superclass? ( class -- ? ) From 8a1ba29743a5050b512c7aa26df84e0c3f5a9edc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 9 Dec 2008 00:58:34 -0600 Subject: [PATCH 131/150] default values for file-systems slots --- basis/tools/files/files.factor | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor index db49dcbf61..a8ce9c9554 100755 --- a/basis/tools/files/files.factor +++ b/basis/tools/files/files.factor @@ -44,12 +44,13 @@ percent-used percent-free ; { device-name [ device-name>> ] } { mount-point [ mount-point>> ] } { type [ type>> ] } - { available-space [ available-space>> ] } - { free-space [ free-space>> ] } - { used-space [ used-space>> ] } - { total-space [ total-space>> ] } + { available-space [ available-space>> [ 0 ] unless* ] } + { free-space [ free-space>> [ 0 ] unless* ] } + { used-space [ used-space>> [ 0 ] unless* ] } + { total-space [ total-space>> [ 0 ] unless* ] } { percent-used [ - [ used-space>> ] [ total-space>> ] bi dup 0 = + [ used-space>> ] [ total-space>> ] bi + [ [ 0 ] unless* ] bi@ dup 0 = [ 2drop 0 ] [ / percent ] if ] } } case ; From db92c905691a0dfb48436555444b5bae6cc77c44 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 9 Dec 2008 01:04:15 -0600 Subject: [PATCH 132/150] Eliminate some usages of locals in compiler.tree.dead-code --- .../tree/dead-code/recursive/recursive.factor | 27 +++++++++---------- 1 file changed, 12 insertions(+), 15 deletions(-) diff --git a/basis/compiler/tree/dead-code/recursive/recursive.factor b/basis/compiler/tree/dead-code/recursive/recursive.factor index 02dc42f058..71830d07e7 100644 --- a/basis/compiler/tree/dead-code/recursive/recursive.factor +++ b/basis/compiler/tree/dead-code/recursive/recursive.factor @@ -22,14 +22,11 @@ M: #call-recursive compute-live-values* [ out-d>> ] [ label>> return>> in-d>> ] bi look-at-mapping ; :: drop-dead-inputs ( inputs outputs -- #shuffle ) - [let* | live-inputs [ inputs filter-live ] - new-live-inputs [ outputs inputs filter-corresponding make-values ] | - live-inputs - new-live-inputs - outputs - inputs - drop-values - ] ; + inputs filter-live + outputs inputs filter-corresponding make-values + outputs + inputs + drop-values ; M: #enter-recursive remove-dead-code* [ filter-live ] change-out-d ; @@ -79,12 +76,12 @@ M: #call-recursive remove-dead-code* bi ] ; -M:: #recursive remove-dead-code* ( node -- nodes ) - [let* | drop-inputs [ node drop-recursive-inputs ] - drop-outputs [ node drop-recursive-outputs ] | - node [ (remove-dead-code) ] change-child drop - node label>> [ filter-live ] change-enter-out drop - { drop-inputs node drop-outputs } - ] ; +M: #recursive remove-dead-code* ( node -- nodes ) + [ drop-recursive-inputs ] + [ + [ (remove-dead-code) ] change-child + dup label>> [ filter-live ] change-enter-out drop + ] + [ drop-recursive-outputs ] tri 3array ; M: #return-recursive remove-dead-code* ; From 6286f9637926fb03fda33427b3c8cd268e262116 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 9 Dec 2008 01:04:22 -0600 Subject: [PATCH 133/150] :> now works --- basis/locals/errors/errors.factor | 9 ++++++ basis/locals/locals-docs.factor | 29 +++++++++++++++++++ basis/locals/locals-tests.factor | 10 +++++++ basis/locals/locals.factor | 9 ++++-- basis/locals/parser/parser.factor | 19 +++++++----- .../rewrite/point-free/point-free.factor | 7 ++--- 6 files changed, 69 insertions(+), 14 deletions(-) diff --git a/basis/locals/errors/errors.factor b/basis/locals/errors/errors.factor index 9f9c2beecc..95c8357939 100644 --- a/basis/locals/errors/errors.factor +++ b/basis/locals/errors/errors.factor @@ -24,8 +24,17 @@ ERROR: local-word-in-literal-error ; M: local-word-in-literal-error summary drop "Local words not permitted inside literals" ; +ERROR: :>-outside-lambda-error ; + +M: :>-outside-lambda-error summary + drop ":> cannot be used outside of lambda expressions" ; + ERROR: bad-lambda-rewrite output ; M: bad-lambda-rewrite summary drop "You have found a bug in locals. Please report." ; +ERROR: bad-local args obj ; + +M: bad-local summary + drop "You have bound a bug in locals. Please report." ; diff --git a/basis/locals/locals-docs.factor b/basis/locals/locals-docs.factor index 89314aadc5..e9e1bfa16a 100644 --- a/basis/locals/locals-docs.factor +++ b/basis/locals/locals-docs.factor @@ -63,6 +63,33 @@ HELP: [wlet } } ; +HELP: :> +{ $syntax ":> binding" } +{ $description "Introduces a new binding, lexically scoped to the enclosing quotation or definition." } +{ $notes + "Lambda and let forms are really just syntax sugar for " { $link POSTPONE: :> } "." + $nl + "Lambdas desugar as follows:" + { $code + "[| a b | a b + b / ]" + "[ :> b :> a a b + b / ]" + } + "Let forms desugar as follows:" + { $code + "[|let | x [ 10 random ] | { x x } ]" + "10 random :> x { x x }" + } +} +{ $examples + { $code + "USING: locals math kernel ;" + "IN: scratchpad" + ":: quadratic ( a b c -- x y )" + " b sq 4 a c * * - sqrt :> disc" + " b neg disc [ + ] [ - ] 2bi [ 2 a * / ] bi@ ;" + } +} ; + HELP: :: { $syntax ":: word ( bindings... -- outputs... ) body... ;" } { $description "Defines a word with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope." } @@ -209,6 +236,8 @@ $nl { $subsection POSTPONE: [wlet } "Lambda abstractions:" { $subsection POSTPONE: [| } +"Lightweight binding form:" +{ $subsection POSTPONE: :> } "Additional topics:" { $subsection "locals-literals" } { $subsection "locals-mutable" } diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index f13c1d57fa..b5c201a5d9 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -441,6 +441,16 @@ M:: integer lambda-method-forget-test ( a -- b ) ; [ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" eval ] must-fail +[ "USE: locals [| | { :> a } ]" eval ] must-fail + +[ "USE: locals 3 :> a" eval ] must-fail + +[ 3 ] [ 3 [| | :> a a ] call ] unit-test + +[ 3 ] [ 3 [| | :> a! a ] call ] unit-test + +[ 3 ] [ 2 [| | :> a! a 1+ a! a ] call ] unit-test + :: wlet-&&-test ( a -- ? ) [wlet | is-integer? [ a integer? ] is-even? [ a even? ] diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index 2060222472..f745f6243f 100644 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -1,10 +1,13 @@ ! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. -USING: lexer locals.parser locals.types macros memoize parser -sequences vocabs vocabs.loader words kernel ; +USING: lexer macros memoize parser sequences vocabs +vocabs.loader words kernel namespaces locals.parser locals.types +locals.errors ; IN: locals -: :> scan parsed ; parsing +: :> + scan locals get [ :>-outside-lambda-error ] unless* + [ make-local ] bind parsed ; parsing : [| parse-lambda parsed-lambda ; parsing diff --git a/basis/locals/parser/parser.factor b/basis/locals/parser/parser.factor index 5b2e7c3eeb..e6ab6c003c 100644 --- a/basis/locals/parser/parser.factor +++ b/basis/locals/parser/parser.factor @@ -20,6 +20,8 @@ IN: locals.parser [ [ dup name>> set ] [ ] [ ] tri ] dip "local-word-def" set-word-prop ; +SYMBOL: locals + : push-locals ( assoc -- ) use get push ; @@ -29,11 +31,16 @@ IN: locals.parser SYMBOL: in-lambda? : (parse-lambda) ( assoc end -- quot ) - t in-lambda? [ parse-until ] with-variable - >quotation swap pop-locals ; + [ + in-lambda? on + over locals set + over push-locals + parse-until >quotation + swap pop-locals + ] with-scope ; : parse-lambda ( -- lambda ) - "|" parse-tokens make-locals dup push-locals + "|" parse-tokens make-locals \ ] (parse-lambda) ; : parse-binding ( end -- pair/f ) @@ -52,15 +59,14 @@ SYMBOL: in-lambda? : parse-bindings ( end -- bindings vars ) [ [ (parse-bindings) ] H{ } make-assoc - dup push-locals ] { } make swap ; : parse-bindings* ( end -- words assoc ) [ [ namespace push-locals - (parse-bindings) + namespace pop-locals ] { } make-assoc ] { } make swap ; @@ -73,13 +79,12 @@ SYMBOL: in-lambda? : parse-wbindings ( end -- bindings vars ) [ [ (parse-wbindings) ] H{ } make-assoc - dup push-locals ] { } make swap ; : parse-locals ( -- vars assoc ) "(" expect ")" parse-effect word [ over "declared-effect" set-word-prop ] when* - in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ; + in>> [ dup pair? [ first ] when ] map make-locals ; : parse-locals-definition ( word -- word quot ) parse-locals \ ; (parse-lambda) diff --git a/basis/locals/rewrite/point-free/point-free.factor b/basis/locals/rewrite/point-free/point-free.factor index 1741bf044f..bd322bfff3 100644 --- a/basis/locals/rewrite/point-free/point-free.factor +++ b/basis/locals/rewrite/point-free/point-free.factor @@ -1,14 +1,13 @@ ! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays fry kernel locals.backend locals.types -math quotations sequences words combinators make ; +USING: accessors arrays fry kernel math quotations sequences +words combinators make locals.backend locals.types +locals.errors ; IN: locals.rewrite.point-free ! Step 3: rewrite locals usage within a single quotation into ! retain stack manipulation -ERROR: bad-local args obj ; - : local-index ( args obj -- n ) 2dup '[ unquote _ eq? ] find drop dup [ 2nip ] [ drop bad-local ] if ; From 3ed7a56a7f1c8df0e940cd795945614289ad4aae Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 9 Dec 2008 01:42:02 -0600 Subject: [PATCH 134/150] Fix functors for locals changes --- basis/functors/functors.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index 7dab80c22d..2029c0cf25 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -99,7 +99,7 @@ DEFER: ;FUNCTOR delimiter : (FUNCTOR:) ( -- word def ) CREATE - parse-locals + parse-locals dup push-locals parse-functor-body swap pop-locals rewrite-closures first ; From 645c9ac1296eb32ae413bef87e760f062c033170 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 9 Dec 2008 02:21:03 -0600 Subject: [PATCH 135/150] Fix load errors related to utf16n being moved to io.encodings.utf16n --- basis/tools/deploy/unix/unix.factor | 4 ++-- basis/tools/deploy/windows/windows.factor | 5 +++-- basis/windows/shell32/shell32.factor | 2 +- basis/windows/windows.factor | 3 ++- 4 files changed, 8 insertions(+), 6 deletions(-) diff --git a/basis/tools/deploy/unix/unix.factor b/basis/tools/deploy/unix/unix.factor index 5e1d0be7fb..bd49155e84 100644 --- a/basis/tools/deploy/unix/unix.factor +++ b/basis/tools/deploy/unix/unix.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. USING: io io.files io.backend kernel namespaces make sequences -system tools.deploy.backend tools.deploy.config assocs -hashtables prettyprint ; +system tools.deploy.backend tools.deploy.config +tools.deploy.config.editor assocs hashtables prettyprint ; IN: tools.deploy.unix : create-app-dir ( vocab bundle-name -- vm ) diff --git a/basis/tools/deploy/windows/windows.factor b/basis/tools/deploy/windows/windows.factor index ec1259c777..6188e78b0e 100755 --- a/basis/tools/deploy/windows/windows.factor +++ b/basis/tools/deploy/windows/windows.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io io.files kernel namespaces sequences system -tools.deploy.backend tools.deploy.config assocs hashtables -prettyprint combinators windows.shell32 windows.user32 ; +tools.deploy.backend tools.deploy.config +tools.deploy.config.editor assocs hashtables prettyprint +combinators windows.shell32 windows.user32 ; IN: tools.deploy.windows : copy-dll ( bundle-name -- ) diff --git a/basis/windows/shell32/shell32.factor b/basis/windows/shell32/shell32.factor index b071bee72a..eae796ac08 100644 --- a/basis/windows/shell32/shell32.factor +++ b/basis/windows/shell32/shell32.factor @@ -1,6 +1,6 @@ USING: alien alien.c-types alien.strings alien.syntax combinators kernel windows windows.user32 windows.ole32 -windows.com windows.com.syntax io.files ; +windows.com windows.com.syntax io.files io.encodings.utf16n ; IN: windows.shell32 : CSIDL_DESKTOP HEX: 00 ; inline diff --git a/basis/windows/windows.factor b/basis/windows/windows.factor index 2fc1dbf122..d2250d6f7e 100644 --- a/basis/windows/windows.factor +++ b/basis/windows/windows.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.syntax alien.c-types alien.strings arrays combinators kernel math namespaces parser prettyprint sequences -windows.errors windows.types windows.kernel32 words ; +windows.errors windows.types windows.kernel32 words +io.encodings.utf16n ; IN: windows : lo-word ( wparam -- lo ) *short ; inline From 05e4626c4991c3fc263f152c3dbfc9c35c386353 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 9 Dec 2008 03:22:09 -0600 Subject: [PATCH 136/150] Clean up --- basis/cpu/x86/assembler/assembler.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index 2bea887295..3a98d47416 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -346,7 +346,7 @@ M: label JUMPcc (JUMPcc) label-fixup ; : LEAVE ( -- ) HEX: c9 , ; : RET ( n -- ) - dup zero? [ drop HEX: c3 , ] [ HEX: C2 , 2, ] if ; + dup zero? [ drop HEX: c3 , ] [ HEX: c2 , 2, ] if ; ! Arithmetic From 1e1640abb3923176474caf73a3f836c4c539f6c8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 9 Dec 2008 03:22:38 -0600 Subject: [PATCH 137/150] Load fixes --- basis/alien/strings/strings-tests.factor | 2 +- basis/environment/winnt/winnt.factor | 2 +- basis/io/encodings/utf16/utf16-tests.factor | 6 ------ basis/io/encodings/utf16n/utf16n-tests.factor | 8 ++++++++ basis/io/windows/files/files.factor | 8 ++++---- basis/io/windows/nt/files/files.factor | 12 ++++++------ basis/io/windows/nt/monitors/monitors.factor | 4 ++-- basis/ui/windows/windows.factor | 3 ++- basis/windows/winsock/winsock.factor | 2 +- basis/x11/xim/xim.factor | 2 +- 10 files changed, 26 insertions(+), 23 deletions(-) create mode 100644 basis/io/encodings/utf16n/utf16n-tests.factor diff --git a/basis/alien/strings/strings-tests.factor b/basis/alien/strings/strings-tests.factor index c1a509041e..263453ba1c 100644 --- a/basis/alien/strings/strings-tests.factor +++ b/basis/alien/strings/strings-tests.factor @@ -1,6 +1,6 @@ USING: alien.strings tools.test kernel libc io.encodings.8-bit io.encodings.utf8 io.encodings.utf16 -io.encodings.ascii alien io.encodings.string ; +io.encodings.utf16n io.encodings.ascii alien io.encodings.string ; IN: alien.strings.tests [ "\u0000ff" ] diff --git a/basis/environment/winnt/winnt.factor b/basis/environment/winnt/winnt.factor index 33cf6a698b..2ad3393aec 100644 --- a/basis/environment/winnt/winnt.factor +++ b/basis/environment/winnt/winnt.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.strings fry io.encodings.utf16 kernel +USING: alien.strings fry io.encodings.utf16n kernel splitting windows windows.kernel32 system environment alien.c-types sequences windows.errors io.streams.memory io.encodings io ; diff --git a/basis/io/encodings/utf16/utf16-tests.factor b/basis/io/encodings/utf16/utf16-tests.factor index fd251c76db..bde92a260d 100644 --- a/basis/io/encodings/utf16/utf16-tests.factor +++ b/basis/io/encodings/utf16/utf16-tests.factor @@ -23,9 +23,3 @@ IN: io.encodings.utf16.tests [ { CHAR: x } ] [ { HEX: fe HEX: ff 0 CHAR: x } utf16 decode >array ] unit-test [ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16 encode >array ] unit-test - -: correct-endian - code>> little-endian? [ utf16le = ] [ utf16be = ] if ; - -[ t ] [ B{ } utf16n correct-endian ] unit-test -[ t ] [ utf16n correct-endian ] unit-test diff --git a/basis/io/encodings/utf16n/utf16n-tests.factor b/basis/io/encodings/utf16n/utf16n-tests.factor new file mode 100644 index 0000000000..d39f2470dd --- /dev/null +++ b/basis/io/encodings/utf16n/utf16n-tests.factor @@ -0,0 +1,8 @@ +USING: accessors alien.c-type kernel io.streams.byte-array tools.test ; +IN: io.encodings.utf16n + +: correct-endian + code>> little-endian? [ utf16le = ] [ utf16be = ] if ; + +[ t ] [ B{ } utf16n correct-endian ] unit-test +[ t ] [ utf16n correct-endian ] unit-test diff --git a/basis/io/windows/files/files.factor b/basis/io/windows/files/files.factor index 83954e045b..894ddc83c6 100755 --- a/basis/io/windows/files/files.factor +++ b/basis/io/windows/files/files.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types io.binary io.backend io.files io.buffers -io.windows kernel math splitting fry alien.strings -windows windows.kernel32 windows.time calendar combinators -math.functions sequences namespaces make words symbols system -io.ports destructors accessors math.bitwise continuations +io.encodings.utf16n io.ports io.windows kernel math splitting +fry alien.strings windows windows.kernel32 windows.time calendar +combinators math.functions sequences namespaces make words +symbols system destructors accessors math.bitwise continuations windows.errors arrays byte-arrays ; IN: io.windows.files diff --git a/basis/io/windows/nt/files/files.factor b/basis/io/windows/nt/files/files.factor index 9f25eb5eb1..e54f032873 100644 --- a/basis/io/windows/nt/files/files.factor +++ b/basis/io/windows/nt/files/files.factor @@ -1,10 +1,10 @@ USING: continuations destructors io.buffers io.files io.backend -io.timeouts io.ports io.windows io.windows.files -io.windows.nt.backend windows windows.kernel32 -kernel libc math threads system environment -alien.c-types alien.arrays alien.strings sequences combinators -combinators.short-circuit ascii splitting alien strings -assocs namespaces make io.files.private accessors tr ; +io.timeouts io.ports io.files.private io.windows +io.windows.files io.windows.nt.backend io.encodings.ut16n +windows windows.kernel32 kernel libc math threads system +environment alien.c-types alien.arrays alien.strings sequences +combinators combinators.short-circuit ascii splitting alien +strings assocs namespaces make accessors tr ; IN: io.windows.nt.files M: winnt cwd diff --git a/basis/io/windows/nt/monitors/monitors.factor b/basis/io/windows/nt/monitors/monitors.factor index 30345c8c69..a2b7c4fa2d 100755 --- a/basis/io/windows/nt/monitors/monitors.factor +++ b/basis/io/windows/nt/monitors/monitors.factor @@ -5,8 +5,8 @@ kernel math assocs namespaces make continuations sequences hashtables sorting arrays combinators math.bitwise strings system accessors threads splitting io.backend io.windows io.windows.nt.backend io.windows.nt.files io.monitors io.ports -io.buffers io.files io.timeouts io.encodings.string io -windows windows.kernel32 windows.types ; +io.buffers io.files io.timeouts io.encodings.string +io.encodings.utf16n io windows windows.kernel32 windows.types ; IN: io.windows.nt.monitors : open-directory ( path -- handle ) diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor index 1481287e95..0510e21f17 100755 --- a/basis/ui/windows/windows.factor +++ b/basis/ui/windows/windows.factor @@ -9,7 +9,8 @@ windows.user32 windows.opengl32 windows.messages windows.types windows.nt windows threads libc combinators combinators.short-circuit continuations command-line shuffle opengl ui.render ascii math.bitwise locals symbols accessors -math.geometry.rect math.order ascii calendar ; +math.geometry.rect math.order ascii calendar +io.encodings.utf16n ; IN: ui.windows SINGLETON: windows-ui-backend diff --git a/basis/windows/winsock/winsock.factor b/basis/windows/winsock/winsock.factor index 4ca07ce850..5d450897e2 100644 --- a/basis/windows/winsock/winsock.factor +++ b/basis/windows/winsock/winsock.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings alien.syntax arrays byte-arrays kernel math sequences windows.types windows.kernel32 -windows.errors windows math.bitwise alias ; +windows.errors windows math.bitwise alias io.encodings.utf16n ; IN: windows.winsock USE: libc diff --git a/basis/x11/xim/xim.factor b/basis/x11/xim/xim.factor index 71b0b5f133..862ec3355a 100644 --- a/basis/x11/xim/xim.factor +++ b/basis/x11/xim/xim.factor @@ -3,7 +3,7 @@ USING: alien alien.c-types alien.strings arrays byte-arrays hashtables io io.encodings.string kernel math namespaces sequences strings continuations x11.xlib specialized-arrays.uint -accessors ; +accessors io.encodings.utf16n ; IN: x11.xim SYMBOL: xim From 474b718337163a1d0a376d210d6538c748bb6a8c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 9 Dec 2008 04:20:20 -0600 Subject: [PATCH 138/150] Add ncleave combinator to generalizations --- basis/generalizations/generalizations-docs.factor | 15 ++++++++++++++- basis/generalizations/generalizations.factor | 4 ++++ 2 files changed, 18 insertions(+), 1 deletion(-) diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index 2380f5614d..3979e0518a 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -1,5 +1,5 @@ USING: help.syntax help.markup kernel sequences quotations -math arrays ; +math arrays combinators ; IN: generalizations HELP: nsequence @@ -234,6 +234,18 @@ HELP: napply } } ; +HELP: ncleave +{ $values { "quots" "a sequence of quotations" } { "n" integer } } +{ $description "A generalization of " { $link cleave } " and " { $link 2cleave } " that can work for any quotation arity." +} +{ $examples + "Some core words expressed in terms of " { $link ncleave } ":" + { $table + { { $link cleave } { $snippet "1 ncleave" } } + { { $link 2cleave } { $snippet "2 ncleave" } } + } +} ; + HELP: mnswap { $values { "m" integer } { "n" integer } } { $description "Swaps the top " { $snippet "m" } " stack elements with the " { $snippet "n" } " elements directly underneath." } @@ -269,6 +281,7 @@ $nl { $subsection nslip } { $subsection nkeep } { $subsection napply } +{ $subsection ncleave } "Generalized quotation construction:" { $subsection ncurry } { $subsection nwith } ; diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 3c24d20c8a..ae7437b346 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -69,6 +69,10 @@ MACRO: ncurry ( n -- ) MACRO: nwith ( n -- ) [ with ] n*quot ; +MACRO: ncleave ( quots n -- ) + [ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi + compose ; + MACRO: napply ( n -- ) 2 [a,b] [ [ 1- ] [ ] bi '[ _ ntuck _ nslip ] ] From 10e1c6b512dfcddbcb96c718c2d93ff6296eed86 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 9 Dec 2008 04:21:50 -0600 Subject: [PATCH 139/150] Fix monads unit tests --- extra/monads/monads-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/monads/monads-tests.factor b/extra/monads/monads-tests.factor index d0014b5abe..44234bc4bc 100644 --- a/extra/monads/monads-tests.factor +++ b/extra/monads/monads-tests.factor @@ -1,4 +1,4 @@ -USING: tools.test monads math kernel sequences lists promises ; +USING: tools.test math kernel sequences lists promises monads ; IN: monads.tests [ 5 ] [ 1 identity-monad return [ 4 + ] fmap run-identity ] unit-test From 9ab4d53213d4d131b15772cb6eb0ab1579c61d12 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 9 Dec 2008 04:22:24 -0600 Subject: [PATCH 140/150] Fix io.encodings.utf16n unit tests --- basis/io/encodings/utf16n/utf16n-tests.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/io/encodings/utf16n/utf16n-tests.factor b/basis/io/encodings/utf16n/utf16n-tests.factor index d39f2470dd..5e7d1af8f5 100644 --- a/basis/io/encodings/utf16n/utf16n-tests.factor +++ b/basis/io/encodings/utf16n/utf16n-tests.factor @@ -1,4 +1,5 @@ -USING: accessors alien.c-type kernel io.streams.byte-array tools.test ; +USING: accessors alien.c-types kernel +io.encodings.utf16 io.streams.byte-array tools.test ; IN: io.encodings.utf16n : correct-endian From ccab34e7c4a51cf7649bbcb31e503b6f840a607b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 9 Dec 2008 04:50:33 -0600 Subject: [PATCH 141/150] Fix restart behavior with circular vocabs, and add a test for this --- core/vocabs/loader/loader-tests.factor | 8 ++++++++ core/vocabs/loader/loader.factor | 1 + core/vocabs/loader/test/j/j.factor | 2 ++ core/vocabs/loader/test/j/tags.txt | 1 + core/vocabs/loader/test/k/k.factor | 2 ++ core/vocabs/loader/test/k/tags.txt | 1 + 6 files changed, 15 insertions(+) create mode 100644 core/vocabs/loader/test/j/j.factor create mode 100644 core/vocabs/loader/test/j/tags.txt create mode 100644 core/vocabs/loader/test/k/k.factor create mode 100644 core/vocabs/loader/test/k/tags.txt diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index e5bd74a981..533bea76fc 100644 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -171,3 +171,11 @@ forget-junk ] with-compilation-unit [ ] [ "vocabs.loader.test.h" require ] unit-test + + +[ + "vocabs.loader.test.j" forget-vocab + "vocabs.loader.test.k" forget-vocab +] with-compilation-unit + +[ ] [ [ "vocabs.loader.test.j" require ] [ drop :1 ] recover ] unit-test diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 6fb0d08811..97fbfe8a07 100644 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -65,6 +65,7 @@ ERROR: circular-dependency name ; [ +parsing+ >>source-loaded? dup vocab-source-path [ parse-file ] [ [ ] ] if* + [ +parsing+ >>source-loaded? ] dip [ % ] [ assert-depth ] if-bootstrapping +done+ >>source-loaded? drop ] [ ] [ f >>source-loaded? ] cleanup ; diff --git a/core/vocabs/loader/test/j/j.factor b/core/vocabs/loader/test/j/j.factor new file mode 100644 index 0000000000..6d545483a3 --- /dev/null +++ b/core/vocabs/loader/test/j/j.factor @@ -0,0 +1,2 @@ +IN: vocabs.loader.test.j +"vocabs.loader.test.k" require diff --git a/core/vocabs/loader/test/j/tags.txt b/core/vocabs/loader/test/j/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/core/vocabs/loader/test/j/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/core/vocabs/loader/test/k/k.factor b/core/vocabs/loader/test/k/k.factor new file mode 100644 index 0000000000..603b48b374 --- /dev/null +++ b/core/vocabs/loader/test/k/k.factor @@ -0,0 +1,2 @@ +IN: vocabs.loader.test.k +USE: vocabs.loader.test.j diff --git a/core/vocabs/loader/test/k/tags.txt b/core/vocabs/loader/test/k/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/core/vocabs/loader/test/k/tags.txt @@ -0,0 +1 @@ +unportable From 43fe6c56a220078d4a6b4d6bdadf67afd2d62aba Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 9 Dec 2008 06:02:39 -0600 Subject: [PATCH 142/150] Windows fixes --- basis/unix/debugger/tags.txt | 1 + extra/game-input/backend/dinput/dinput.factor | 13 +++++++------ 2 files changed, 8 insertions(+), 6 deletions(-) create mode 100644 basis/unix/debugger/tags.txt diff --git a/basis/unix/debugger/tags.txt b/basis/unix/debugger/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/debugger/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/game-input/backend/dinput/dinput.factor b/extra/game-input/backend/dinput/dinput.factor index 116faf60cd..b66a722258 100755 --- a/extra/game-input/backend/dinput/dinput.factor +++ b/extra/game-input/backend/dinput/dinput.factor @@ -1,10 +1,11 @@ -USING: windows.dinput windows.dinput.constants parser -symbols alien.c-types windows.ole32 namespaces assocs kernel -arrays vectors windows.kernel32 windows.com windows.dinput -shuffle windows.user32 windows.messages sequences combinators +USING: windows.dinput windows.dinput.constants parser symbols +alien.c-types windows.ole32 namespaces assocs kernel arrays +vectors windows.kernel32 windows.com windows.dinput shuffle +windows.user32 windows.messages sequences combinators math.geometry.rect ui.windows accessors math windows alien -alien.strings io.encodings.utf16 continuations byte-arrays -locals game-input.backend.dinput.keys-array ; +alien.strings io.encodings.utf16 io.encodings.utf16n +continuations byte-arrays locals +game-input.backend.dinput.keys-array ; << "game-input" (use+) >> IN: game-input.backend.dinput From 6745e0dad9e7b46878b483e4d28fc6316f46b6fb Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Tue, 9 Dec 2008 12:35:59 -0800 Subject: [PATCH 143/150] Fix error in the docs for assoc-map. --- core/assocs/assocs-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index b02e0189b2..662d667485 100644 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -214,7 +214,7 @@ HELP: assoc-map { $examples { $unchecked-example ": discount ( prices n -- newprices )" - " [ - ] curry assoc-each ;" + " [ - ] curry assoc-map ;" "H{ { \"bananas\" 5 } { \"apples\" 42 } { \"pears\" 17 } }" "2 discount ." "H{ { \"bananas\" 3 } { \"apples\" 39 } { \"pears\" 15 } }" From ea4feee886fc3f62d12e6fb40890931045ff6d2c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 9 Dec 2008 15:10:51 -0600 Subject: [PATCH 144/150] Fix typo --- core/classes/tuple/tuple-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 3bac6c87b3..5b1844b78b 100644 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -197,7 +197,7 @@ ARTICLE: "tuple-introspection" "Tuple introspection" ARTICLE: "tuple-examples" "Tuple examples" "An example:" -{ $code "TUPLE: employee name salary position ;" } +{ $code "TUPLE: employee name position salary ;" } "This defines a class word named " { $snippet "employee" } ", a predicate " { $snippet "employee?" } ", and the following slot accessors:" { $table { "Reader" "Writer" "Setter" "Changer" } @@ -237,7 +237,7 @@ ARTICLE: "tuple-examples" "Tuple examples" " checks counter check boa ;" "" ": biweekly-paycheck ( employee -- check )" - " dup name>> swap salary>> 26 / ;" + " [ name>> ] [ salary>> 26 / ] bi ;" } "An example of using a changer:" { $code From 9ad51490afe7d5354d8575f8bf943596d44bc2dc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 9 Dec 2008 16:26:30 -0600 Subject: [PATCH 145/150] Fix GC crash with -generations=2 --- vm/code_heap.c | 2 ++ vm/data_gc.c | 4 +--- vm/data_gc.h | 1 + 3 files changed, 4 insertions(+), 3 deletions(-) diff --git a/vm/code_heap.c b/vm/code_heap.c index 6ed5ea4309..9a1c45c7df 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -147,6 +147,8 @@ void apply_relocation(CELL class, CELL offset, F_FIXNUM absolute_value) /* Perform all fixups on a code block */ void relocate_code_block(F_COMPILED *compiled, CELL code_start, CELL literals_start) { + compiled->last_scan = NURSERY; + if(compiled->relocation != F) { F_BYTE_ARRAY *relocation = untag_object(compiled->relocation); diff --git a/vm/data_gc.c b/vm/data_gc.c index 6e15718b2d..2122f930f0 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -32,9 +32,7 @@ F_DATA_HEAP *alloc_data_heap(CELL gens, data_heap->gen_count = gens; CELL total_size; - if(data_heap->gen_count == 1) - total_size = 2 * tenured_size; - else if(data_heap->gen_count == 2) + if(data_heap->gen_count == 2) total_size = young_size + 2 * tenured_size; else if(data_heap->gen_count == 3) total_size = young_size + 2 * aging_size + 2 * tenured_size; diff --git a/vm/data_gc.h b/vm/data_gc.h index 4ec3fdd5f2..6d367a25fd 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -137,6 +137,7 @@ void collect_cards(void); /* the oldest generation */ #define TENURED (data_heap->gen_count-1) +#define MIN_GEN_COUNT 1 #define MAX_GEN_COUNT 3 /* used during garbage collection only */ From d771e8a30619d29b56ed6396fe8354627efc66c3 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Tue, 9 Dec 2008 23:37:27 +0100 Subject: [PATCH 146/150] FUEL debug mode: :warnings &co. retrievable, and some cosmetics. --- extra/fuel/fuel.factor | 17 +++--- misc/fuel/fuel-debug.el | 124 +++++++++++++++++++++++++--------------- misc/fuel/fuel-mode.el | 10 ++-- 3 files changed, 92 insertions(+), 59 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index acaccf5b78..d9db83b5e3 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -104,21 +104,20 @@ M: source-file fuel-pprint path>> fuel-pprint ; fuel-eval-output get-global 3array fuel-pprint ; -: fuel-forget-error ( -- ) - f error set-global ; inline +: fuel-forget-error ( -- ) f error set-global ; inline +: fuel-forget-result ( -- ) f fuel-eval-result set-global ; inline +: fuel-forget-output ( -- ) f fuel-eval-output set-global ; inline : (fuel-begin-eval) ( -- ) push-fuel-status display-stacks? off fuel-forget-error - f fuel-eval-result set-global - f fuel-eval-output set-global ; - -: fuel-run-with-output ( quot -- ) - with-string-writer fuel-eval-output set-global ; inline + fuel-forget-result + fuel-forget-output ; : (fuel-end-eval) ( quot -- ) - fuel-run-with-output fuel-retort pop-fuel-status ; inline + with-string-writer fuel-eval-output set-global + fuel-retort pop-fuel-status ; inline : (fuel-eval) ( lines -- ) [ [ parse-lines ] with-compilation-unit call ] curry @@ -129,7 +128,7 @@ M: source-file fuel-pprint path>> fuel-pprint ; : (fuel-eval-usings) ( usings -- ) [ "USING: " prepend " ;" append ] map - (fuel-eval-each) fuel-forget-error ; + (fuel-eval-each) fuel-forget-error fuel-forget-output ; : (fuel-eval-in) ( in -- ) [ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ; inline diff --git a/misc/fuel/fuel-debug.el b/misc/fuel/fuel-debug.el index 1b68f6e79f..b3aad7f3dc 100644 --- a/misc/fuel/fuel-debug.el +++ b/misc/fuel/fuel-debug.el @@ -45,7 +45,42 @@ (restart-name function-name "restart names"))) -;;; Compilation results buffer: +;;; Font lock and other pattern matching: + +(defconst fuel-debug--compiler-info-alist + '((":warnings" . ?w) (":errors" . ?e) (":linkage" . ?l))) + +(defconst fuel-debug--error-file-regex "^P\" \\([^\"]+\\)\"") +(defconst fuel-debug--error-line-regex "\\([0-9]+\\):") +(defconst fuel-debug--error-cont-regex "^ +\\(\\^\\)$") + +(defconst fuel-debug--error-regex + (format "%s\n%s" + fuel-debug--error-file-regex + fuel-debug--error-line-regex)) + +(defconst fuel-debug--compiler-info-regex + (format "^\\(%s\\) " + (regexp-opt (mapcar 'car fuel-debug--compiler-info-alist)))) + +(defconst fuel-debug--restart-regex "^:\\([0-9]+\\) \\(.+\\)") + +(defconst fuel-debug--font-lock-keywords + `((,fuel-debug--error-file-regex . 'fuel-debug-font-lock-error) + (,fuel-debug--error-line-regex 1 'fuel-debug-font-lock-line) + (,fuel-debug--error-cont-regex 1 'fuel-debug-font-lock-column) + (,fuel-debug--restart-regex (1 'fuel-debug-font-lock-restart-number) + (2 'fuel-debug-font-lock-restart-name)) + (,fuel-debug--compiler-info-regex 1 'fuel-debug-font-lock-restart-number) + ("^\\(Restarts?\\|Loading\\) .+$" . 'fuel-debug-font-lock-info) + ("^Error: " . 'fuel-debug-font-lock-error))) + +(defun fuel-debug--font-lock-setup () + (set (make-local-variable 'font-lock-defaults) + '(fuel-debug--font-lock-keywords t nil nil nil))) + + +;;; Debug buffer: (defvar fuel-debug--buffer nil) @@ -67,50 +102,63 @@ (inhibit-read-only t)) (with-current-buffer (fuel-debug--buffer) (erase-buffer) - (when err (insert (format "Error: %S\n\n" (fuel-eval--error-name err)))) - (fuel-debug--display-output-1 ret) + (fuel-debug--display-output ret) + (delete-blank-lines) + (newline) (when (and (not err) success-msg) (message "%s" success-msg) (insert "\n" success-msg "\n")) (when err (fuel-debug--display-restarts err) - (let ((hstr (fuel-debug--help-string err))) + (delete-blank-lines) + (newline) + (let ((hstr (fuel-debug--help-string err file))) (if fuel-debug-show-short-help (insert "-----------\n" hstr "\n") (message "%s" hstr)))) (setq fuel-debug--last-ret ret) (setq fuel-debug--file file) - (goto-char (point-max))) - (when (and err (not no-pop)) (pop-to-buffer fuel-debug--buffer)))) + (goto-char (point-max)) + (when (and err (not no-pop)) (pop-to-buffer fuel-debug--buffer)) + (not err)))) -(defun fuel-debug--display-output-1 (ret) +(defun fuel-debug--display-output (ret) (let* ((last (fuel-eval--retort-output fuel-debug--last-ret)) (current (fuel-eval--retort-output ret)) (llen (length last)) (clen (length current)) (trail (and last (substring-no-properties last (/ llen 2)))) + (err (fuel-eval--retort-error ret)) (p (point))) (save-excursion (insert current)) (when (and (> clen llen) (> llen 0) (search-forward trail nil t)) (delete-region p (point))) - (goto-char (point-max)))) + (goto-char (point-max)) + (when err + (insert (format "\nError: %S\n\n" (fuel-eval--error-name err)))))) (defun fuel-debug--display-restarts (err) (let* ((rs (fuel-eval--error-restarts err)) (rsn (length rs))) (when rs - (insert "\n\nRestarts:\n\n") + (insert "Restarts:\n\n") (dotimes (n rsn) (insert (format ":%s %s\n" (1+ n) (nth n rs)))) (newline)))) -(defun fuel-debug--help-string (err) - (format "Press %s%s 'q' to bury buffer" - (if (fuel-eval--error-file err) "g to visit file, " "") +(defun fuel-debug--help-string (err &optional file) + (format "Press %s%s%sq bury buffer" + (if (or file (fuel-eval--error-file err)) "g go to file, " "") (let ((rsn (length (fuel-eval--error-restarts err)))) (cond ((zerop rsn) "") - ((= 1 rsn) "1 to invoke restart, ") - (t (format "1-%s to invoke restarts, " rsn)))))) + ((= 1 rsn) "1 invoke restart, ") + (t (format "1-%s invoke restarts, " rsn)))) + (let ((str "")) + (dolist (ci fuel-debug--compiler-info-alist str) + (save-excursion + (goto-char (point-min)) + (when (search-forward (car ci) nil t) + (setq str (format "%c %s, %s" (cdr ci) (car ci) str)))))))) (defun fuel-debug--buffer-file () (with-current-buffer (fuel-debug--buffer) @@ -126,44 +174,13 @@ (fuel-eval--error-restarts (fuel-debug--buffer-error))) -;;; Font lock and other pattern matching: - -(defconst fuel-debug--error-file-regex "^P\" \\([^\"]+\\)\"") -(defconst fuel-debug--error-line-regex "\\([0-9]+\\):") -(defconst fuel-debug--error-cont-regex "^ +\\(\\^\\)$") - -(defconst fuel-debug--error-regex - (format "%s\n%s" - fuel-debug--error-file-regex - fuel-debug--error-line-regex)) - -(defconst fuel-debug--named-restart-regex - (format "^\\(%s\\) " (regexp-opt '(":warnings" ":errors" ":linkage")))) - -(defconst fuel-debug--restart-regex - "^:\\([0-9]+\\) \\(.+\\)") - -(defconst fuel-debug--font-lock-keywords - `((,fuel-debug--error-file-regex . 'fuel-debug-font-lock-error) - (,fuel-debug--error-line-regex 1 'fuel-debug-font-lock-line) - (,fuel-debug--error-cont-regex 1 'fuel-debug-font-lock-column) - (,fuel-debug--restart-regex (1 'fuel-debug-font-lock-restart-number) - (2 'fuel-debug-font-lock-restart-name)) - (,fuel-debug--named-restart-regex 1 'fuel-debug-font-lock-restart-number) - ("^\\(Restarts?\\|Loading\\) .+$" . 'fuel-debug-font-lock-info) - ("^Error: " . 'fuel-debug-font-lock-error))) - -(defun fuel-debug--font-lock-setup () - (set (make-local-variable 'font-lock-defaults) - '(fuel-debug--font-lock-keywords t nil nil nil))) - ;;; Buffer navigation: (defun fuel-debug-goto-error () (interactive) (let* ((err (or (fuel-debug--buffer-error) (error "No errors reported"))) - (file (or (fuel-eval--error-file err) + (file (or (fuel-debug--buffer-file) (error "No file associated with error"))) (l/c (fuel-eval--error-line/column err)) (line (or (car l/c) 1)) @@ -200,6 +217,16 @@ (fuel-eval--eval-string/context (format ":%s" n)) (format "Restart %s (%s) successful" n (nth (1- n) rs)))))))) +(defun fuel-debug-show--compiler-info (info) + (save-excursion + (goto-char (point-min)) + (unless (re-search-forward (format "^%s" info) nil t) + (error "%s information not available" info)) + (message "Retrieving %s info ..." info) + (unless (fuel-debug--display-retort + (fuel-eval--eval-string info) "" (fuel-debug--buffer-file)) + (error "Sorry, no %s info available" info)))) + ;;; Fuel Debug mode: @@ -208,10 +235,15 @@ (suppress-keymap map) (define-key map "g" 'fuel-debug-goto-error) (define-key map "\C-c\C-c" 'fuel-debug-goto-error) + (define-key map "n" 'next-line) + (define-key map "p" 'previous-line) (define-key map "q" 'bury-buffer) (dotimes (n 9) (define-key map (vector (+ ?1 n)) `(lambda () (interactive) (fuel-debug-exec-restart ,(1+ n) t)))) + (dolist (ci fuel-debug--compiler-info-alist) + (define-key map (vector (cdr ci)) + `(lambda () (interactive) (fuel-debug-show--compiler-info ,(car ci))))) map)) (defun fuel-debug-mode () diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index 0a459e4381..ea1d4b93ed 100644 --- a/misc/fuel/fuel-mode.el +++ b/misc/fuel/fuel-mode.el @@ -49,10 +49,12 @@ With prefix argument, ask for the file to run." (cmd (format "%S fuel-run-file" file))) (when buffer (with-current-buffer buffer - (fuel-debug--display-retort (fuel-eval--eval-string/context cmd) - (format "%s successfully compiled" file) - nil - file))))) + (message "Compiling %s ..." file) + (let ((r (fuel-debug--display-retort (fuel-eval--eval-string/context cmd) + (format "%s successfully compiled" file) + nil + file))) + (if r (message "Compiling %s ... OK!" file) (message ""))))))) (defun fuel-eval-region (begin end &optional arg) "Sends region to Fuel's listener for evaluation. From b5e8b14722cd2a8bf976741bfffc833ff2e40a65 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 9 Dec 2008 16:45:02 -0600 Subject: [PATCH 147/150] Add unit test for GC problem --- core/memory/memory-tests.factor | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor index 1c23e700ca..6794825897 100644 --- a/core/memory/memory-tests.factor +++ b/core/memory/memory-tests.factor @@ -1,8 +1,16 @@ USING: generic kernel kernel.private math memory prettyprint io sequences tools.test words namespaces layouts classes -classes.builtin arrays quotations ; +classes.builtin arrays quotations io.launcher system ; IN: memory.tests +! LOL +[ ] [ + vm + "-generations=2" + "-e=USING: memory io prettyprint system ; input-stream gc . 0 exit" + 3array try-process +] unit-test + [ [ ] instances ] must-infer ! Code GC wasn't kicking in when needed From a90118da5dac22baab0f1a0d495130842ece2c56 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 9 Dec 2008 16:54:48 -0600 Subject: [PATCH 148/150] Add inc-at word to core, and update some usages of at+ to use it instead --- basis/compiler/tree/debugger/debugger.factor | 4 ++-- basis/compiler/tree/propagation/inlining/inlining.factor | 2 +- basis/locals/locals-docs.factor | 2 ++ basis/logging/analysis/analysis.factor | 6 +++--- basis/tools/memory/memory.factor | 2 +- core/assocs/assocs-docs.factor | 6 ++++++ core/assocs/assocs.factor | 5 +++-- 7 files changed, 18 insertions(+), 9 deletions(-) diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index 8a2823010d..e75e7f6046 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -151,14 +151,14 @@ SYMBOL: node-count H{ } clone intrinsics-called set 0 swap [ - >r 1+ r> + [ 1+ ] dip dup #call? [ word>> { { [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] } { [ dup generic? ] [ generics-called ] } { [ dup method-body? ] [ methods-called ] } [ words-called ] - } cond 1 -rot get at+ + } cond inc-at ] [ drop ] if ] each-node node-count set diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index e35eb02604..bd6d657442 100644 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -152,7 +152,7 @@ DEFER: (flat-length) SYMBOL: history : remember-inlining ( word -- ) - [ [ 1 ] dip inlining-count get at+ ] + [ inlining-count get inc-at ] [ history [ swap suffix ] change ] bi ; diff --git a/basis/locals/locals-docs.factor b/basis/locals/locals-docs.factor index e9e1bfa16a..77b87d1b49 100644 --- a/basis/locals/locals-docs.factor +++ b/basis/locals/locals-docs.factor @@ -67,6 +67,8 @@ HELP: :> { $syntax ":> binding" } { $description "Introduces a new binding, lexically scoped to the enclosing quotation or definition." } { $notes + "This word can only be used inside a lambda word, lambda quotation or let binding form." + $nl "Lambda and let forms are really just syntax sugar for " { $link POSTPONE: :> } "." $nl "Lambdas desugar as follows:" diff --git a/basis/logging/analysis/analysis.factor b/basis/logging/analysis/analysis.factor index d84e49f784..24810a6c3e 100644 --- a/basis/logging/analysis/analysis.factor +++ b/basis/logging/analysis/analysis.factor @@ -13,10 +13,10 @@ SYMBOL: message-histogram : analyze-entry ( entry -- ) dup level>> { ERROR CRITICAL } memq? [ dup errors get push ] when - 1 over word-name>> word-histogram get at+ + dup word-name>> word-histogram get inc-at dup word-name>> word-names get member? [ - 1 over [ level>> ] [ word-name>> ] [ message>> ] tri 3array - message-histogram get at+ + dup [ level>> ] [ word-name>> ] [ message>> ] tri 3array + message-histogram get inc-at ] when drop ; diff --git a/basis/tools/memory/memory.factor b/basis/tools/memory/memory.factor index 8c35ae25a8..2ad16a4d8d 100644 --- a/basis/tools/memory/memory.factor +++ b/basis/tools/memory/memory.factor @@ -53,7 +53,7 @@ IN: tools.memory : heap-stat-step ( obj counts sizes -- ) [ over ] dip - [ [ [ drop 1 ] [ class ] bi ] dip at+ ] + [ [ class ] dip inc-at ] [ [ [ size ] [ class ] bi ] dip at+ ] 2bi* ; PRIVATE> diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index 662d667485..2f486cd948 100644 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -90,6 +90,7 @@ ARTICLE: "assocs-mutation" "Storing keys and values in assocs" { $subsection rename-at } { $subsection change-at } { $subsection at+ } +{ $subsection inc-at } { $see-also set-at delete-at clear-assoc push-at } ; ARTICLE: "assocs-conversions" "Associative mapping conversions" @@ -349,6 +350,11 @@ HELP: at+ { $description "Adds " { $snippet "n" } " to the value associated with " { $snippet "key" } "; if there is no value, stores " { $snippet "n" } ", thus behaving as if the value was 0." } { $side-effects "assoc" } ; +HELP: inc-at +{ $values { "key" object } { "assoc" assoc } } +{ $description "Adds 1 to the value associated with " { $snippet "key" } "; if there is no value, stores 1." } +{ $side-effects "assoc" } ; + HELP: >alist { $values { "assoc" assoc } { "newassoc" "an array of key/value pairs" } } { $contract "Converts an associative structure into an association list." } diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 76745cc015..320e370ec9 100644 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -141,8 +141,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) : change-at ( key assoc quot -- ) [ [ at ] dip call ] 3keep drop set-at ; inline -: at+ ( n key assoc -- ) - [ 0 or + ] change-at ; +: at+ ( n key assoc -- ) [ 0 or + ] change-at ; inline + +: inc-at ( key assoc -- ) [ 1 ] 2dip at+ ; inline : map>assoc ( seq quot exemplar -- assoc ) [ [ 2array ] compose { } map-as ] dip assoc-like ; inline From 4b927f732f90a6f4076fe82c0e6154aefd85ca93 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 9 Dec 2008 17:14:17 -0600 Subject: [PATCH 149/150] Clean up JIT backend a little --- basis/cpu/x86/32/bootstrap.factor | 14 +- basis/cpu/x86/64/bootstrap.factor | 15 +- basis/cpu/x86/64/unix/bootstrap.factor | 3 - basis/cpu/x86/64/winnt/bootstrap.factor | 3 - basis/cpu/x86/bootstrap.factor | 434 ++++++++++++++---------- 5 files changed, 274 insertions(+), 195 deletions(-) diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index 04bdcca68b..698c3a1766 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -10,19 +10,19 @@ IN: bootstrap.x86 : shift-arg ( -- reg ) ECX ; : div-arg ( -- reg ) EAX ; : mod-arg ( -- reg ) EDX ; -: arg0 ( -- reg ) EAX ; -: arg1 ( -- reg ) EDX ; -: arg2 ( -- reg ) ECX ; -: temp-reg ( -- reg ) EBX ; +: temp0 ( -- reg ) EAX ; +: temp1 ( -- reg ) EDX ; +: temp2 ( -- reg ) ECX ; +: temp3 ( -- reg ) EBX ; : stack-reg ( -- reg ) ESP ; : ds-reg ( -- reg ) ESI ; : rs-reg ( -- reg ) EDI ; -: fixnum>slot@ ( -- ) arg0 1 SAR ; +: fixnum>slot@ ( -- ) temp0 1 SAR ; : rex-length ( -- n ) 0 ; [ - arg0 0 [] MOV ! load stack_chain - arg0 [] stack-reg MOV ! save stack pointer + temp0 0 [] MOV ! load stack_chain + temp0 [] stack-reg MOV ! save stack pointer ] rc-absolute-cell rt-stack-chain 2 jit-save-stack jit-define [ diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index 83a72d6dd3..efa3de3065 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -9,7 +9,10 @@ IN: bootstrap.x86 : shift-arg ( -- reg ) RCX ; : div-arg ( -- reg ) RAX ; : mod-arg ( -- reg ) RDX ; -: temp-reg ( -- reg ) RBX ; +: temp0 ( -- reg ) RDI ; +: temp1 ( -- reg ) RSI ; +: temp2 ( -- reg ) RDX ; +: temp3 ( -- reg ) RBX ; : stack-reg ( -- reg ) RSP ; : ds-reg ( -- reg ) R14 ; : rs-reg ( -- reg ) R15 ; @@ -17,14 +20,14 @@ IN: bootstrap.x86 : rex-length ( -- n ) 1 ; [ - arg0 0 MOV ! load stack_chain - arg0 arg0 [] MOV - arg0 [] stack-reg MOV ! save stack pointer + temp0 0 MOV ! load stack_chain + temp0 temp0 [] MOV + temp0 [] stack-reg MOV ! save stack pointer ] rc-absolute-cell rt-stack-chain 1 rex-length + jit-save-stack jit-define [ - arg1 0 MOV ! load XT - arg1 JMP ! go + temp1 0 MOV ! load XT + temp1 JMP ! go ] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define << "resource:basis/cpu/x86/bootstrap.factor" parse-file parsed >> diff --git a/basis/cpu/x86/64/unix/bootstrap.factor b/basis/cpu/x86/64/unix/bootstrap.factor index f0ca56da14..a21c4534d2 100644 --- a/basis/cpu/x86/64/unix/bootstrap.factor +++ b/basis/cpu/x86/64/unix/bootstrap.factor @@ -5,9 +5,6 @@ cpu.x86.assembler layouts vocabs parser ; IN: bootstrap.x86 : stack-frame-size ( -- n ) 4 bootstrap-cells ; -: arg0 ( -- reg ) RDI ; -: arg1 ( -- reg ) RSI ; -: arg2 ( -- reg ) RDX ; << "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >> call diff --git a/basis/cpu/x86/64/winnt/bootstrap.factor b/basis/cpu/x86/64/winnt/bootstrap.factor index 459945d82e..709f138463 100644 --- a/basis/cpu/x86/64/winnt/bootstrap.factor +++ b/basis/cpu/x86/64/winnt/bootstrap.factor @@ -5,9 +5,6 @@ cpu.x86.assembler layouts vocabs parser ; IN: bootstrap.x86 : stack-frame-size ( -- n ) 8 bootstrap-cells ; -: arg0 ( -- reg ) RCX ; -: arg1 ( -- reg ) RDX ; -: arg2 ( -- reg ) R8 ; << "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >> call diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 597a2c9d31..3451da78e1 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -12,28 +12,35 @@ big-endian off [ ! Load word - temp-reg 0 MOV + temp0 0 MOV ! Bump profiling counter - temp-reg profile-count-offset [+] 1 tag-fixnum ADD + temp0 profile-count-offset [+] 1 tag-fixnum ADD ! Load word->code - temp-reg temp-reg word-code-offset [+] MOV + temp0 temp0 word-code-offset [+] MOV ! Compute word XT - temp-reg compiled-header-size ADD + temp0 compiled-header-size ADD ! Jump to XT - temp-reg JMP + temp0 JMP ] rc-absolute-cell rt-immediate 1 rex-length + jit-profiling jit-define [ - temp-reg 0 MOV ! load XT - stack-frame-size PUSH ! save stack frame size - temp-reg PUSH ! push XT - stack-reg stack-frame-size 3 bootstrap-cells - SUB ! alignment + ! load XT + temp0 0 MOV + ! save stack frame size + stack-frame-size PUSH + ! push XT + temp0 PUSH + ! alignment + stack-reg stack-frame-size 3 bootstrap-cells - SUB ] rc-absolute-cell rt-label 1 rex-length + jit-prolog jit-define [ - arg0 0 MOV ! load literal - ds-reg bootstrap-cell ADD ! increment datastack pointer - ds-reg [] arg0 MOV ! store literal on datastack + ! load literal + temp0 0 MOV + ! increment datastack pointer + ds-reg bootstrap-cell ADD + ! store literal on datastack + ds-reg [] temp0 MOV ] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define [ @@ -45,73 +52,85 @@ big-endian off ] rc-relative rt-xt 1 jit-word-call jit-define [ - arg0 ds-reg [] MOV ! load boolean - ds-reg bootstrap-cell SUB ! pop boolean - arg0 \ f tag-number CMP ! compare boolean with f - f JNE ! jump to true branch if not equal + ! load boolean + temp0 ds-reg [] MOV + ! pop boolean + ds-reg bootstrap-cell SUB + ! compare boolean with f + temp0 \ f tag-number CMP + ! jump to true branch if not equal + f JNE ] rc-relative rt-xt 10 rex-length 3 * + jit-if-1 jit-define [ - f JMP ! jump to false branch if equal + ! jump to false branch if equal + f JMP ] rc-relative rt-xt 1 jit-if-2 jit-define [ - arg1 0 MOV ! load dispatch table - arg0 ds-reg [] MOV ! load index - fixnum>slot@ ! turn it into an array offset - ds-reg bootstrap-cell SUB ! pop index - arg0 arg1 ADD ! compute quotation location - arg0 arg0 array-start-offset [+] MOV ! load quotation - arg0 quot-xt-offset [+] JMP ! execute branch + ! load dispatch table + temp1 0 MOV + ! load index + temp0 ds-reg [] MOV + ! turn it into an array offset + fixnum>slot@ + ! pop index + ds-reg bootstrap-cell SUB + ! compute quotation location + temp0 temp1 ADD + ! load quotation + temp0 temp0 array-start-offset [+] MOV + ! execute branch + temp0 quot-xt-offset [+] JMP ] rc-absolute-cell rt-immediate 1 rex-length + jit-dispatch jit-define : jit->r ( -- ) rs-reg bootstrap-cell ADD - arg0 ds-reg [] MOV + temp0 ds-reg [] MOV ds-reg bootstrap-cell SUB - rs-reg [] arg0 MOV ; + rs-reg [] temp0 MOV ; : jit-2>r ( -- ) rs-reg 2 bootstrap-cells ADD - arg0 ds-reg [] MOV - arg1 ds-reg -1 bootstrap-cells [+] MOV + temp0 ds-reg [] MOV + temp1 ds-reg -1 bootstrap-cells [+] MOV ds-reg 2 bootstrap-cells SUB - rs-reg [] arg0 MOV - rs-reg -1 bootstrap-cells [+] arg1 MOV ; + rs-reg [] temp0 MOV + rs-reg -1 bootstrap-cells [+] temp1 MOV ; : jit-3>r ( -- ) rs-reg 3 bootstrap-cells ADD - arg0 ds-reg [] MOV - arg1 ds-reg -1 bootstrap-cells [+] MOV - arg2 ds-reg -2 bootstrap-cells [+] MOV + temp0 ds-reg [] MOV + temp1 ds-reg -1 bootstrap-cells [+] MOV + temp2 ds-reg -2 bootstrap-cells [+] MOV ds-reg 3 bootstrap-cells SUB - rs-reg [] arg0 MOV - rs-reg -1 bootstrap-cells [+] arg1 MOV - rs-reg -2 bootstrap-cells [+] arg2 MOV ; + rs-reg [] temp0 MOV + rs-reg -1 bootstrap-cells [+] temp1 MOV + rs-reg -2 bootstrap-cells [+] temp2 MOV ; : jit-r> ( -- ) ds-reg bootstrap-cell ADD - arg0 rs-reg [] MOV + temp0 rs-reg [] MOV rs-reg bootstrap-cell SUB - ds-reg [] arg0 MOV ; + ds-reg [] temp0 MOV ; : jit-2r> ( -- ) ds-reg 2 bootstrap-cells ADD - arg0 rs-reg [] MOV - arg1 rs-reg -1 bootstrap-cells [+] MOV + temp0 rs-reg [] MOV + temp1 rs-reg -1 bootstrap-cells [+] MOV rs-reg 2 bootstrap-cells SUB - ds-reg [] arg0 MOV - ds-reg -1 bootstrap-cells [+] arg1 MOV ; + ds-reg [] temp0 MOV + ds-reg -1 bootstrap-cells [+] temp1 MOV ; : jit-3r> ( -- ) ds-reg 3 bootstrap-cells ADD - arg0 rs-reg [] MOV - arg1 rs-reg -1 bootstrap-cells [+] MOV - arg2 rs-reg -2 bootstrap-cells [+] MOV + temp0 rs-reg [] MOV + temp1 rs-reg -1 bootstrap-cells [+] MOV + temp2 rs-reg -2 bootstrap-cells [+] MOV rs-reg 3 bootstrap-cells SUB - ds-reg [] arg0 MOV - ds-reg -1 bootstrap-cells [+] arg1 MOV - ds-reg -2 bootstrap-cells [+] arg2 MOV ; + ds-reg [] temp0 MOV + ds-reg -1 bootstrap-cells [+] temp1 MOV + ds-reg -2 bootstrap-cells [+] temp2 MOV ; [ jit->r @@ -126,13 +145,14 @@ big-endian off ] rc-relative rt-xt 17 rex-length 6 * + jit-2dip jit-define [ - jit-3>r + jit-3>r f CALL jit-3r> ] rc-relative rt-xt 23 rex-length 8 * + jit-3dip jit-define [ - stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame + ! unwind stack frame + stack-reg stack-frame-size bootstrap-cell - ADD ] f f f jit-epilog jit-define [ 0 RET ] f f f jit-return jit-define @@ -141,34 +161,51 @@ big-endian off ! Quotations and words [ - arg0 ds-reg [] MOV ! load from stack - ds-reg bootstrap-cell SUB ! pop stack - arg0 quot-xt-offset [+] JMP ! call quotation + ! load from stack + temp0 ds-reg [] MOV + ! pop stack + ds-reg bootstrap-cell SUB + ! call quotation + temp0 quot-xt-offset [+] JMP ] f f f \ (call) define-sub-primitive [ - arg0 ds-reg [] MOV ! load from stack - ds-reg bootstrap-cell SUB ! pop stack - arg0 word-xt-offset [+] JMP ! execute word + ! load from stack + temp0 ds-reg [] MOV + ! pop stack + ds-reg bootstrap-cell SUB + ! execute word + temp0 word-xt-offset [+] JMP ] f f f \ (execute) define-sub-primitive ! Objects [ - arg1 ds-reg [] MOV ! load from stack - arg1 tag-mask get AND ! compute tag - arg1 tag-bits get SHL ! tag the tag - ds-reg [] arg1 MOV ! push to stack + ! load from stack + temp0 ds-reg [] MOV + ! compute tag + temp0 tag-mask get AND + ! tag the tag + temp0 tag-bits get SHL + ! push to stack + ds-reg [] temp0 MOV ] f f f \ tag define-sub-primitive [ - arg0 ds-reg [] MOV ! load slot number - ds-reg bootstrap-cell SUB ! adjust stack pointer - arg1 ds-reg [] MOV ! load object - fixnum>slot@ ! turn slot number into offset - arg1 tag-bits get SHR ! mask off tag - arg1 tag-bits get SHL - arg0 arg1 arg0 [+] MOV ! load slot value - ds-reg [] arg0 MOV ! push to stack + ! load slot number + temp0 ds-reg [] MOV + ! adjust stack pointer + ds-reg bootstrap-cell SUB + ! load object + temp1 ds-reg [] MOV + ! turn slot number into offset + fixnum>slot@ + ! mask off tag + temp1 tag-bits get SHR + temp1 tag-bits get SHL + ! load slot value + temp0 temp1 temp0 [+] MOV + ! push to stack + ds-reg [] temp0 MOV ] f f f \ slot define-sub-primitive ! Shufflers @@ -185,100 +222,100 @@ big-endian off ] f f f \ 3drop define-sub-primitive [ - arg0 ds-reg [] MOV + temp0 ds-reg [] MOV ds-reg bootstrap-cell ADD - ds-reg [] arg0 MOV + ds-reg [] temp0 MOV ] f f f \ dup define-sub-primitive [ - arg0 ds-reg [] MOV - arg1 ds-reg bootstrap-cell neg [+] MOV + temp0 ds-reg [] MOV + temp1 ds-reg bootstrap-cell neg [+] MOV ds-reg 2 bootstrap-cells ADD - ds-reg [] arg0 MOV - ds-reg bootstrap-cell neg [+] arg1 MOV + ds-reg [] temp0 MOV + ds-reg bootstrap-cell neg [+] temp1 MOV ] f f f \ 2dup define-sub-primitive [ - arg0 ds-reg [] MOV - arg1 ds-reg -1 bootstrap-cells [+] MOV - temp-reg ds-reg -2 bootstrap-cells [+] MOV + temp0 ds-reg [] MOV + temp1 ds-reg -1 bootstrap-cells [+] MOV + temp3 ds-reg -2 bootstrap-cells [+] MOV ds-reg 3 bootstrap-cells ADD - ds-reg [] arg0 MOV - ds-reg -1 bootstrap-cells [+] arg1 MOV - ds-reg -2 bootstrap-cells [+] temp-reg MOV + ds-reg [] temp0 MOV + ds-reg -1 bootstrap-cells [+] temp1 MOV + ds-reg -2 bootstrap-cells [+] temp3 MOV ] f f f \ 3dup define-sub-primitive [ - arg0 ds-reg [] MOV + temp0 ds-reg [] MOV ds-reg bootstrap-cell SUB - ds-reg [] arg0 MOV + ds-reg [] temp0 MOV ] f f f \ nip define-sub-primitive [ - arg0 ds-reg [] MOV + temp0 ds-reg [] MOV ds-reg 2 bootstrap-cells SUB - ds-reg [] arg0 MOV + ds-reg [] temp0 MOV ] f f f \ 2nip define-sub-primitive [ - arg0 ds-reg -1 bootstrap-cells [+] MOV + temp0 ds-reg -1 bootstrap-cells [+] MOV ds-reg bootstrap-cell ADD - ds-reg [] arg0 MOV + ds-reg [] temp0 MOV ] f f f \ over define-sub-primitive [ - arg0 ds-reg -2 bootstrap-cells [+] MOV + temp0 ds-reg -2 bootstrap-cells [+] MOV ds-reg bootstrap-cell ADD - ds-reg [] arg0 MOV + ds-reg [] temp0 MOV ] f f f \ pick define-sub-primitive [ - arg0 ds-reg [] MOV - arg1 ds-reg -1 bootstrap-cells [+] MOV - ds-reg [] arg1 MOV + temp0 ds-reg [] MOV + temp1 ds-reg -1 bootstrap-cells [+] MOV + ds-reg [] temp1 MOV ds-reg bootstrap-cell ADD - ds-reg [] arg0 MOV + ds-reg [] temp0 MOV ] f f f \ dupd define-sub-primitive [ - arg0 ds-reg [] MOV - arg1 ds-reg -1 bootstrap-cells [+] MOV + temp0 ds-reg [] MOV + temp1 ds-reg -1 bootstrap-cells [+] MOV ds-reg bootstrap-cell ADD - ds-reg [] arg0 MOV - ds-reg -1 bootstrap-cells [+] arg1 MOV - ds-reg -2 bootstrap-cells [+] arg0 MOV + ds-reg [] temp0 MOV + ds-reg -1 bootstrap-cells [+] temp1 MOV + ds-reg -2 bootstrap-cells [+] temp0 MOV ] f f f \ tuck define-sub-primitive [ - arg0 ds-reg [] MOV - arg1 ds-reg bootstrap-cell neg [+] MOV - ds-reg bootstrap-cell neg [+] arg0 MOV - ds-reg [] arg1 MOV + temp0 ds-reg [] MOV + temp1 ds-reg bootstrap-cell neg [+] MOV + ds-reg bootstrap-cell neg [+] temp0 MOV + ds-reg [] temp1 MOV ] f f f \ swap define-sub-primitive [ - arg0 ds-reg -1 bootstrap-cells [+] MOV - arg1 ds-reg -2 bootstrap-cells [+] MOV - ds-reg -2 bootstrap-cells [+] arg0 MOV - ds-reg -1 bootstrap-cells [+] arg1 MOV + temp0 ds-reg -1 bootstrap-cells [+] MOV + temp1 ds-reg -2 bootstrap-cells [+] MOV + ds-reg -2 bootstrap-cells [+] temp0 MOV + ds-reg -1 bootstrap-cells [+] temp1 MOV ] f f f \ swapd define-sub-primitive [ - arg0 ds-reg [] MOV - arg1 ds-reg -1 bootstrap-cells [+] MOV - temp-reg ds-reg -2 bootstrap-cells [+] MOV - ds-reg -2 bootstrap-cells [+] arg1 MOV - ds-reg -1 bootstrap-cells [+] arg0 MOV - ds-reg [] temp-reg MOV + temp0 ds-reg [] MOV + temp1 ds-reg -1 bootstrap-cells [+] MOV + temp3 ds-reg -2 bootstrap-cells [+] MOV + ds-reg -2 bootstrap-cells [+] temp1 MOV + ds-reg -1 bootstrap-cells [+] temp0 MOV + ds-reg [] temp3 MOV ] f f f \ rot define-sub-primitive [ - arg0 ds-reg [] MOV - arg1 ds-reg -1 bootstrap-cells [+] MOV - temp-reg ds-reg -2 bootstrap-cells [+] MOV - ds-reg -2 bootstrap-cells [+] arg0 MOV - ds-reg -1 bootstrap-cells [+] temp-reg MOV - ds-reg [] arg1 MOV + temp0 ds-reg [] MOV + temp1 ds-reg -1 bootstrap-cells [+] MOV + temp3 ds-reg -2 bootstrap-cells [+] MOV + ds-reg -2 bootstrap-cells [+] temp0 MOV + ds-reg -1 bootstrap-cells [+] temp3 MOV + ds-reg [] temp1 MOV ] f f f \ -rot define-sub-primitive [ jit->r ] f f f \ >r define-sub-primitive @@ -287,14 +324,20 @@ big-endian off ! Comparisons : jit-compare ( insn -- ) - temp-reg 0 MOV ! load t - arg1 \ f tag-number MOV ! load f - arg0 ds-reg [] MOV ! load first value - ds-reg bootstrap-cell SUB ! adjust stack pointer - ds-reg [] arg0 CMP ! compare with second value - [ arg1 temp-reg ] dip execute ! move t if true - ds-reg [] arg1 MOV ! store - ; + ! load t + temp3 0 MOV + ! load f + temp1 \ f tag-number MOV + ! load first value + temp0 ds-reg [] MOV + ! adjust stack pointer + ds-reg bootstrap-cell SUB + ! compare with second value + ds-reg [] temp0 CMP + ! move t if true + [ temp1 temp3 ] dip execute + ! store + ds-reg [] temp1 MOV ; : define-jit-compare ( insn word -- ) [ [ jit-compare ] curry rc-absolute-cell rt-immediate 1 rex-length + ] dip @@ -308,22 +351,30 @@ big-endian off ! Math : jit-math ( insn -- ) - arg0 ds-reg [] MOV ! load second input - ds-reg bootstrap-cell SUB ! pop stack - [ ds-reg [] arg0 ] dip execute ! compute result - ; + ! load second input + temp0 ds-reg [] MOV + ! pop stack + ds-reg bootstrap-cell SUB + ! compute result + [ ds-reg [] temp0 ] dip execute ; [ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive [ \ SUB jit-math ] f f f \ fixnum-fast define-sub-primitive [ - arg0 ds-reg [] MOV ! load second input - ds-reg bootstrap-cell SUB ! pop stack - arg1 ds-reg [] MOV ! load first input - arg0 tag-bits get SAR ! untag second input - arg0 arg1 IMUL2 ! multiply - ds-reg [] arg1 MOV ! push result + ! load second input + temp0 ds-reg [] MOV + ! pop stack + ds-reg bootstrap-cell SUB + ! load first input + temp1 ds-reg [] MOV + ! untag second input + temp0 tag-bits get SAR + ! multiply + temp0 temp1 IMUL2 + ! push result + ds-reg [] temp1 MOV ] f f f \ fixnum*fast define-sub-primitive [ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive @@ -333,75 +384,106 @@ big-endian off [ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive [ - ds-reg [] NOT ! complement - ds-reg [] tag-mask get XOR ! clear tag bits + ! complement + ds-reg [] NOT + ! clear tag bits + ds-reg [] tag-mask get XOR ] f f f \ fixnum-bitnot define-sub-primitive [ - shift-arg ds-reg [] MOV ! load shift count - shift-arg tag-bits get SAR ! untag shift count - ds-reg bootstrap-cell SUB ! adjust stack pointer - temp-reg ds-reg [] MOV ! load value - arg1 temp-reg MOV ! make a copy - arg1 CL SHL ! compute positive shift value in arg1 - shift-arg NEG ! compute negative shift value in arg0 - temp-reg CL SAR - temp-reg tag-mask get bitnot AND - shift-arg 0 CMP ! if shift count was negative, move arg0 to arg1 - arg1 temp-reg CMOVGE - ds-reg [] arg1 MOV ! push to stack + ! load shift count + shift-arg ds-reg [] MOV + ! untag shift count + shift-arg tag-bits get SAR + ! adjust stack pointer + ds-reg bootstrap-cell SUB + ! load value + temp3 ds-reg [] MOV + ! make a copy + temp1 temp3 MOV + ! compute positive shift value in temp1 + temp1 CL SHL + shift-arg NEG + ! compute negative shift value in temp3 + temp3 CL SAR + temp3 tag-mask get bitnot AND + shift-arg 0 CMP + ! if shift count was negative, move temp0 to temp1 + temp1 temp3 CMOVGE + ! push to stack + ds-reg [] temp1 MOV ] f f f \ fixnum-shift-fast define-sub-primitive : jit-fixnum-/mod ( -- ) - temp-reg ds-reg [] MOV ! load second parameter - div-arg ds-reg bootstrap-cell neg [+] MOV ! load first parameter - mod-arg div-arg MOV ! make a copy - mod-arg bootstrap-cell-bits 1- SAR ! sign-extend - temp-reg IDIV ; ! divide + ! load second parameter + temp3 ds-reg [] MOV + ! load first parameter + div-arg ds-reg bootstrap-cell neg [+] MOV + ! make a copy + mod-arg div-arg MOV + ! sign-extend + mod-arg bootstrap-cell-bits 1- SAR + ! divide + temp3 IDIV ; [ jit-fixnum-/mod - ds-reg bootstrap-cell SUB ! adjust stack pointer - ds-reg [] mod-arg MOV ! push to stack + ! adjust stack pointer + ds-reg bootstrap-cell SUB + ! push to stack + ds-reg [] mod-arg MOV ] f f f \ fixnum-mod define-sub-primitive [ jit-fixnum-/mod - ds-reg bootstrap-cell SUB ! adjust stack pointer - div-arg tag-bits get SHL ! tag it - ds-reg [] div-arg MOV ! push to stack + ! adjust stack pointer + ds-reg bootstrap-cell SUB + ! tag it + div-arg tag-bits get SHL + ! push to stack + ds-reg [] div-arg MOV ] f f f \ fixnum/i-fast define-sub-primitive [ jit-fixnum-/mod - div-arg tag-bits get SHL ! tag it - ds-reg [] mod-arg MOV ! push to stack + ! tag it + div-arg tag-bits get SHL + ! push to stack + ds-reg [] mod-arg MOV ds-reg bootstrap-cell neg [+] div-arg MOV ] f f f \ fixnum/mod-fast define-sub-primitive [ - arg0 ds-reg [] MOV + temp0 ds-reg [] MOV ds-reg bootstrap-cell SUB - arg0 ds-reg [] OR - arg0 tag-mask get AND - arg0 \ f tag-number MOV - arg1 1 tag-fixnum MOV - arg0 arg1 CMOVE - ds-reg [] arg0 MOV + temp0 ds-reg [] OR + temp0 tag-mask get AND + temp0 \ f tag-number MOV + temp1 1 tag-fixnum MOV + temp0 temp1 CMOVE + ds-reg [] temp0 MOV ] f f f \ both-fixnums? define-sub-primitive [ - arg0 ds-reg [] MOV ! load local number - fixnum>slot@ ! turn local number into offset - arg0 rs-reg arg0 [+] MOV ! load local value - ds-reg [] arg0 MOV ! push to stack + ! load local number + temp0 ds-reg [] MOV + ! turn local number into offset + fixnum>slot@ + ! load local value + temp0 rs-reg temp0 [+] MOV + ! push to stack + ds-reg [] temp0 MOV ] f f f \ get-local define-sub-primitive [ - arg0 ds-reg [] MOV ! load local count - ds-reg bootstrap-cell SUB ! adjust stack pointer - fixnum>slot@ ! turn local number into offset - rs-reg arg0 SUB ! decrement retain stack pointer + ! load local count + temp0 ds-reg [] MOV + ! adjust stack pointer + ds-reg bootstrap-cell SUB + ! turn local number into offset + fixnum>slot@ + ! decrement retain stack pointer + rs-reg temp0 SUB ] f f f \ drop-locals define-sub-primitive [ "bootstrap.x86" forget-vocab ] with-compilation-unit From c2504f207d18d477bc1a5c550cb8821b77b8844a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 9 Dec 2008 17:49:03 -0600 Subject: [PATCH 150/150] Use kqueue on Mac OS X instead of select --- basis/io/unix/backend/backend.factor | 4 +-- basis/io/unix/kqueue/kqueue.factor | 40 ++++++++++++---------------- basis/io/unix/macosx/macosx.factor | 6 ++++- basis/unix/kqueue/kqueue.factor | 3 ++- 4 files changed, 26 insertions(+), 27 deletions(-) diff --git a/basis/io/unix/backend/backend.factor b/basis/io/unix/backend/backend.factor index 85363c8404..1666d60c83 100644 --- a/basis/io/unix/backend/backend.factor +++ b/basis/io/unix/backend/backend.factor @@ -64,10 +64,10 @@ M: mx remove-output-callbacks writes>> delete-at* drop ; GENERIC: wait-for-events ( ms mx -- ) : input-available ( fd mx -- ) - remove-input-callbacks [ resume ] each ; + reads>> delete-at* drop [ resume ] each ; : output-available ( fd mx -- ) - remove-output-callbacks [ resume ] each ; + writes>> delete-at* drop [ resume ] each ; M: fd cancel-operation ( fd -- ) dup disposed>> [ drop ] [ diff --git a/basis/io/unix/kqueue/kqueue.factor b/basis/io/unix/kqueue/kqueue.factor index 6b687a8afb..b4e2b7af6f 100644 --- a/basis/io/unix/kqueue/kqueue.factor +++ b/basis/io/unix/kqueue/kqueue.factor @@ -2,10 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types combinators io.unix.backend kernel math.bitwise sequences struct-arrays unix unix.kqueue -unix.time ; +unix.time assocs ; IN: io.unix.kqueue -TUPLE: kqueue-mx < mx events monitors ; +TUPLE: kqueue-mx < mx events ; : max-events ( -- n ) #! We read up to 256 events at a time. This is an arbitrary @@ -14,7 +14,6 @@ TUPLE: kqueue-mx < mx events monitors ; : ( -- mx ) kqueue-mx new-mx - H{ } clone >>monitors kqueue dup io-error >>fd max-events "kevent" >>events ; @@ -35,30 +34,25 @@ M: kqueue-mx add-input-callback ( thread fd mx -- ) M: kqueue-mx add-output-callback ( thread fd mx -- ) [ call-next-method ] [ - [ EVFILT_WRITE EV_DELETE make-kevent ] dip + [ EVFILT_WRITE { EV_ADD EV_ONESHOT } flags make-kevent ] dip register-kevent ] 2bi ; -: cancel-input-callbacks ( fd mx -- seq ) - [ - [ EVFILT_READ EV_DELETE make-kevent ] dip - register-kevent - ] [ remove-input-callbacks ] 2bi ; +M: kqueue-mx remove-input-callbacks ( fd mx -- seq ) + 2dup reads>> key? [ + [ call-next-method ] [ + [ EVFILT_READ EV_DELETE make-kevent ] dip + register-kevent + ] 2bi + ] [ 2drop f ] if ; -: cancel-output-callbacks ( fd mx -- seq ) - [ - [ EVFILT_WRITE EV_DELETE make-kevent ] dip - register-kevent - ] [ remove-output-callbacks ] 2bi ; - -M: fd cancel-operation ( fd -- ) - dup disposed>> [ drop ] [ - fd>> - mx get-global - [ cancel-input-callbacks [ t swap resume-with ] each ] - [ cancel-output-callbacks [ t swap resume-with ] each ] - 2bi - ] if ; +M: kqueue-mx remove-output-callbacks ( fd mx -- seq ) + 2dup writes>> key? [ + [ + [ EVFILT_WRITE EV_DELETE make-kevent ] dip + register-kevent + ] [ call-next-method ] 2bi + ] [ 2drop f ] if ; : wait-kevent ( mx timespec -- n ) [ diff --git a/basis/io/unix/macosx/macosx.factor b/basis/io/unix/macosx/macosx.factor index 77140b81c9..ef52b676fb 100644 --- a/basis/io/unix/macosx/macosx.factor +++ b/basis/io/unix/macosx/macosx.factor @@ -1,6 +1,10 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: io.unix.macosx -USING: io.unix.bsd io.backend system ; +USING: io.unix.backend io.unix.bsd io.unix.kqueue io.backend +namespaces system ; + +M: macosx init-io ( -- ) + mx set-global ; macosx set-io-backend diff --git a/basis/unix/kqueue/kqueue.factor b/basis/unix/kqueue/kqueue.factor index 83c3bb5232..d7623df8be 100644 --- a/basis/unix/kqueue/kqueue.factor +++ b/basis/unix/kqueue/kqueue.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax system sequences vocabs.loader words ; +USING: alien.syntax system sequences vocabs.loader words +accessors ; IN: unix.kqueue << "unix.kqueue." os name>> append require >>