From 12c8ffc19494b866bc1be006cf27b6ac7fe21037 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 4 Dec 2008 21:22:48 -0600
Subject: [PATCH 01/72] Fix adding methods to existing classes
---
basis/cocoa/cocoa-tests.factor | 26 ++++++++-
basis/cocoa/subclassing/subclassing.factor | 67 ++++++++++------------
2 files changed, 55 insertions(+), 38 deletions(-)
diff --git a/basis/cocoa/cocoa-tests.factor b/basis/cocoa/cocoa-tests.factor
index e1d6672872..59ea91c3cf 100644
--- a/basis/cocoa/cocoa-tests.factor
+++ b/basis/cocoa/cocoa-tests.factor
@@ -1,7 +1,7 @@
IN: cocoa.tests
USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
compiler kernel namespaces cocoa.classes tools.test memory
-compiler.units ;
+compiler.units math ;
CLASS: {
{ +superclass+ "NSObject" }
@@ -45,3 +45,27 @@ Bar [
[ 2.0 ] [ "x" get NSRect-y ] unit-test
[ 101.0 ] [ "x" get NSRect-w ] unit-test
[ 102.0 ] [ "x" get NSRect-h ] unit-test
+
+! Make sure that we can add methods
+CLASS: {
+ { +superclass+ "NSObject" }
+ { +name+ "Bar" }
+} {
+ "bar"
+ "NSRect"
+ { "id" "SEL" }
+ [ 2drop test-foo "x" get ]
+} {
+ "babb"
+ "int"
+ { "id" "SEL" "int" }
+ [ 2nip sq ]
+} ;
+
+[ 144 ] [
+ Bar [
+ -> alloc -> init
+ dup 12 -> babb
+ swap -> release
+ ] compile-call
+] unit-test
diff --git a/basis/cocoa/subclassing/subclassing.factor b/basis/cocoa/subclassing/subclassing.factor
index 40f21d25b8..b49d55a30b 100644
--- a/basis/cocoa/subclassing/subclassing.factor
+++ b/basis/cocoa/subclassing/subclassing.factor
@@ -1,10 +1,9 @@
-! Copyright (C) 2006, 2008 Slava Pestov
+! Copyright (C) 2006, 2008 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings arrays assocs
combinators compiler hashtables kernel libc math namespaces
-parser sequences words cocoa.messages cocoa.runtime
-compiler.units io.encodings.ascii generalizations
-continuations make ;
+parser sequences words cocoa.messages cocoa.runtime locals
+compiler.units io.encodings.ascii continuations make fry ;
IN: cocoa.subclassing
: init-method ( method -- sel imp types )
@@ -12,22 +11,25 @@ IN: cocoa.subclassing
[ sel_registerName ] [ execute ] [ ascii string>alien ]
tri* ;
-: throw-if-false ( YES/NO -- )
- zero? [ "Failed to add method or protocol to class" throw ]
- when ;
+: throw-if-false ( obj what -- )
+ swap { f 0 } member?
+ [ "Failed to " prepend throw ] [ drop ] if ;
+
+: add-method ( class sel imp types -- )
+ class_addMethod "add method to class" throw-if-false ;
: add-methods ( methods class -- )
- swap
- [ init-method class_addMethod throw-if-false ] with each ;
+ '[ [ _ ] dip init-method add-method ] each ;
+
+: add-protocol ( class protocol -- )
+ class_addProtocol "add protocol to class" throw-if-false ;
: add-protocols ( protocols class -- )
- swap [ objc-protocol class_addProtocol throw-if-false ]
- with each ;
+ '[ [ _ ] dip objc-protocol add-protocol ] each ;
-: (define-objc-class) ( protocols superclass name imeth -- )
- -rot
+: (define-objc-class) ( imeth protocols superclass name -- )
[ objc-class ] dip 0 objc_allocateClassPair
- [ add-methods ] [ add-protocols ] [ objc_registerClassPair ]
+ [ add-protocols ] [ add-methods ] [ objc_registerClassPair ]
tri ;
: encode-types ( return types -- encoding )
@@ -45,28 +47,19 @@ IN: cocoa.subclassing
[ first4 prepare-method 3array ] map
] with-compilation-unit ;
-: types= ( a b -- ? )
- [ ascii alien>string ] bi@ = ;
-
-: (verify-method-type) ( class sel types -- )
- [ class_getInstanceMethod method_getTypeEncoding ]
- dip types=
- [ "Objective-C method types cannot be changed once defined" throw ]
- unless ;
-: verify-method-type ( class sel imp types -- class sel imp types )
- 4 ndup nip (verify-method-type) ;
-
-: (redefine-objc-method) ( class method -- )
- init-method ! verify-method-type
- drop
- [ class_getInstanceMethod ] dip method_setImplementation drop ;
+:: (redefine-objc-method) ( class method -- )
+ method init-method [| sel imp types |
+ class sel class_getInstanceMethod [
+ imp method_setImplementation drop
+ ] [
+ class sel imp types add-method
+ ] if*
+ ] call ;
: redefine-objc-methods ( imeth name -- )
dup class-exists? [
- objc_getClass swap [ (redefine-objc-method) ] with each
- ] [
- 2drop
- ] if ;
+ objc_getClass '[ [ _ ] dip (redefine-objc-method) ] each
+ ] [ 2drop ] if ;
SYMBOL: +name+
SYMBOL: +protocols+
@@ -76,10 +69,10 @@ SYMBOL: +superclass+
clone [
prepare-methods
+name+ get "cocoa.classes" create drop
- +name+ get 2dup redefine-objc-methods swap [
- +protocols+ get , +superclass+ get , +name+ get , ,
- \ (define-objc-class) ,
- ] [ ] make import-objc-class
+ +name+ get 2dup redefine-objc-methods swap
+ +protocols+ get +superclass+ get +name+ get
+ '[ _ _ _ _ (define-objc-class) ]
+ import-objc-class
] bind ;
: CLASS:
From 0e0e79eb7ec5c6627c2bd979040d80f2c31deaf5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 5 Dec 2008 01:49:46 -0600
Subject: [PATCH 02/72] Redo how Cocoa event loop is done; fixes problem with
expose, focus issue when closing windows
---
basis/cocoa/application/application.factor | 19 +++++-------
basis/cocoa/messages/messages.factor | 34 ++++++++++++----------
basis/ui/cocoa/cocoa.factor | 21 ++++++++++---
basis/ui/cocoa/tools/tools.factor | 6 ++--
4 files changed, 46 insertions(+), 34 deletions(-)
diff --git a/basis/cocoa/application/application.factor b/basis/cocoa/application/application.factor
index c62fab0f15..ab12a93a31 100644
--- a/basis/cocoa/application/application.factor
+++ b/basis/cocoa/application/application.factor
@@ -27,17 +27,19 @@ IN: cocoa.application
: NSApp ( -- app ) NSApplication -> sharedApplication ;
+: NSAnyEventMask ( -- mask ) HEX: ffffffff ; inline
+
FUNCTION: void NSBeep ( ) ;
: with-cocoa ( quot -- )
[ NSApp drop call ] with-autorelease-pool ; inline
: next-event ( app -- event )
- 0 f CFRunLoopDefaultMode 1
+ NSAnyEventMask f CFRunLoopDefaultMode 1
-> nextEventMatchingMask:untilDate:inMode:dequeue: ;
: do-event ( app -- ? )
- dup next-event [ -> sendEvent: t ] [ drop f ] if* ;
+ dup next-event [ dupd -> sendEvent: -> updateWindows t ] [ drop f ] if* ;
: add-observer ( observer selector name object -- )
[
@@ -49,14 +51,7 @@ FUNCTION: void NSBeep ( ) ;
[ NSNotificationCenter -> defaultCenter ] dip
-> removeObserver: ;
-: finish-launching ( -- ) NSApp -> finishLaunching ;
-
-: cocoa-app ( quot -- )
- [
- call
- finish-launching
- NSApp -> run
- ] with-cocoa ; inline
+: cocoa-app ( quot -- ) [ call NSApp -> run ] with-cocoa ; inline
: install-delegate ( receiver delegate -- )
-> alloc -> init -> setDelegate: ;
@@ -81,6 +76,6 @@ M: objc-error summary ( error -- )
running.app? [
drop
] [
- "The " swap " requires you to run Factor from an application bundle."
- 3append throw
+ "The " " requires you to run Factor from an application bundle."
+ surround throw
] if ;
diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor
index 791674428b..4be90a5a95 100644
--- a/basis/cocoa/messages/messages.factor
+++ b/basis/cocoa/messages/messages.factor
@@ -85,9 +85,17 @@ MACRO: (send) ( selector super? -- quot )
\ super-send soft "break-after" set-word-prop
! Runtime introspection
-: (objc-class) ( string word -- class )
- dupd execute
- [ ] [ "No such class: " prepend throw ] ?if ; inline
+SYMBOL: class-init-hooks
+
+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*
+ 2dup execute dup [ 2nip ] [
+ 2drop "No such class: " prepend throw
+ ] if
+ ] if ; inline
: objc-class ( string -- class )
\ objc_getClass (objc-class) ;
@@ -221,23 +229,19 @@ assoc-union alien>objc-types set-global
: class-exists? ( string -- class ) objc_getClass >boolean ;
-: unless-defined ( class quot -- )
- [ class-exists? ] dip unless ; inline
-
-: define-objc-class-word ( name quot -- )
+: define-objc-class-word ( quot name -- )
+ [ class-init-hooks get set-at ]
[
- over , , \ unless-defined , dup , \ objc-class ,
- ] [ ] make [ "cocoa.classes" create ] dip
- (( -- class )) define-declared ;
+ [ "cocoa.classes" create ] [ '[ _ objc-class ] ] bi
+ (( -- class )) define-declared
+ ] bi ;
: import-objc-class ( name quot -- )
- 2dup unless-defined
- dupd define-objc-class-word
+ over define-objc-class-word
'[
_
- dup
- objc-class register-objc-methods
- objc-meta-class register-objc-methods
+ [ objc-class register-objc-methods ]
+ [ objc-meta-class register-objc-methods ] bi
] try ;
: root-class ( class -- root )
diff --git a/basis/ui/cocoa/cocoa.factor b/basis/ui/cocoa/cocoa.factor
index a9b3b03b75..42063fbf73 100644
--- a/basis/ui/cocoa/cocoa.factor
+++ b/basis/ui/cocoa/cocoa.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors math arrays cocoa cocoa.application
+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
@@ -96,16 +96,29 @@ M: cocoa-ui-backend flush-gl-context ( handle -- )
M: cocoa-ui-backend beep ( -- )
NSBeep ;
+CLASS: {
+ { +superclass+ "NSObject" }
+ { +name+ "FactorApplicationDelegate" }
+}
+
+{ "applicationDidFinishLaunching:" "void" { "id" "SEL" "id" }
+ [ 3drop event-loop ]
+} ;
+
+: install-app-delegate ( -- )
+ NSApp FactorApplicationDelegate install-delegate ;
+
SYMBOL: cocoa-init-hook
+cocoa-init-hook global [ [ install-app-delegate ] or ] change-at
+
M: cocoa-ui-backend ui
"UI" assert.app [
[
init-clipboard
- cocoa-init-hook get [ call ] when*
+ cocoa-init-hook get call
start-ui
- finish-launching
- event-loop
+ NSApp -> run
] ui-running
] with-cocoa ;
diff --git a/basis/ui/cocoa/tools/tools.factor b/basis/ui/cocoa/tools/tools.factor
index a8ade05a86..ccaae0c1ab 100644
--- a/basis/ui/cocoa/tools/tools.factor
+++ b/basis/ui/cocoa/tools/tools.factor
@@ -20,8 +20,8 @@ IN: ui.cocoa.tools
! Handle Open events from the Finder
CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "FactorApplicationDelegate" }
+ { +superclass+ "FactorApplicationDelegate" }
+ { +name+ "FactorWorkspaceApplicationDelegate" }
}
{ "application:openFiles:" "void" { "id" "SEL" "id" "id" }
@@ -49,7 +49,7 @@ CLASS: {
} ;
: install-app-delegate ( -- )
- NSApp FactorApplicationDelegate install-delegate ;
+ NSApp FactorWorkspaceApplicationDelegate install-delegate ;
! Service support; evaluate Factor code from other apps
:: do-service ( pboard error quot -- )
From 6c7005d588b56ea9e3471b3e1bdc952fd5283d87 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 5 Dec 2008 01:50:14 -0600
Subject: [PATCH 03/72] Tweak inlining heuristic
---
basis/compiler/tree/propagation/inlining/inlining.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor
index 3a94029756..87a908041e 100644
--- a/basis/compiler/tree/propagation/inlining/inlining.factor
+++ b/basis/compiler/tree/propagation/inlining/inlining.factor
@@ -128,8 +128,8 @@ DEFER: (flat-length)
45 node-count get [-] 8 /i ;
: body-length-bias ( word -- n )
- [ flat-length ] [ inlining-count get at 0 or 2/ 1+ ] bi *
- 24 swap [-] 4 /i ;
+ [ flat-length ] [ inlining-count get at 0 or ] bi
+ over 2 <= [ drop ] [ 2/ 1+ * ] if 24 swap [-] 4 /i ;
: inlining-rank ( #call word -- n )
[ classes-known? 2 0 ? ]
From 25bf16f6d46f33b6576a23cf4ff407eac2442eba Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 5 Dec 2008 01:50:30 -0600
Subject: [PATCH 04/72] Optimize mersenne-twister: eliminate conditional
branches from inner loop, 30% speedup
---
.../mersenne-twister/mersenne-twister.factor | 51 ++++++++-----------
1 file changed, 21 insertions(+), 30 deletions(-)
diff --git a/basis/random/mersenne-twister/mersenne-twister.factor b/basis/random/mersenne-twister/mersenne-twister.factor
index 357ab87966..67b0fa23e7 100644
--- a/basis/random/mersenne-twister/mersenne-twister.factor
+++ b/basis/random/mersenne-twister/mersenne-twister.factor
@@ -11,48 +11,39 @@ IN: random.mersenne-twister
TUPLE: mersenne-twister { seq uint-array } { i fixnum } ;
-: mt-n 624 ; inline
-: mt-m 397 ; inline
-: mt-a HEX: 9908b0df ; inline
+: n 624 ; inline
+: m 397 ; inline
+: a uint-array{ 0 HEX: 9908b0df } ; inline
-: mersenne-wrap ( n -- n' )
- dup mt-n > [ mt-n - ] when ; inline
+: y ( n seq -- y )
+ [ nth-unsafe 31 mask-bit ]
+ [ [ 1+ ] [ nth-unsafe ] bi* 31 bits ] 2bi bitor ; inline
-: wrap-nth ( n seq -- obj )
- [ mersenne-wrap ] dip nth-unsafe ; inline
-
-: set-wrap-nth ( obj n seq -- )
- [ mersenne-wrap ] dip set-nth-unsafe ; inline
-
-: calculate-y ( n seq -- y )
- [ wrap-nth 31 mask-bit ]
- [ [ 1+ ] [ wrap-nth ] bi* 31 bits ] 2bi bitor ; inline
-
-: (mt-generate) ( n seq -- next-mt )
+: mt[k] ( offset n seq -- )
[
- calculate-y
- [ 2/ ] [ odd? mt-a 0 ? ] bi bitxor
- ] [
- [ mt-m + ] [ wrap-nth ] bi*
- ] 2bi bitxor ; inline
+ [ [ + ] dip nth-unsafe ]
+ [ y [ 2/ ] [ 1 bitand a nth ] bi bitxor ] 2bi
+ bitxor
+ ] 2keep set-nth-unsafe ; inline
: mt-generate ( mt -- )
[
- mt-n swap seq>> '[
- _ [ (mt-generate) ] [ set-wrap-nth ] 2bi
- ] each
+ seq>>
+ [ [ n m - ] dip '[ [ m ] dip _ mt[k] ] each ]
+ [ [ m 1- ] dip '[ [ m n - ] [ n m - + ] bi* _ mt[k] ] each ]
+ bi
] [ 0 >>i drop ] bi ; inline
: init-mt-formula ( i seq -- f(seq[i]) )
- dupd wrap-nth dup -30 shift bitxor 1812433253 * + 1+ 32 bits ; inline
+ dupd nth dup -30 shift bitxor 1812433253 * + 1+ 32 bits ; inline
: init-mt-rest ( seq -- )
- mt-n 1- swap '[
- _ [ init-mt-formula ] [ [ 1+ ] dip set-wrap-nth ] 2bi
+ n 1- swap '[
+ _ [ init-mt-formula ] [ [ 1+ ] dip set-nth ] 2bi
] each ; inline
: init-mt-seq ( seed -- seq )
- 32 bits mt-n <uint-array>
+ 32 bits n <uint-array>
[ set-first ] [ init-mt-rest ] [ ] tri ; inline
: mt-temper ( y -- yt )
@@ -62,7 +53,7 @@ TUPLE: mersenne-twister { seq uint-array } { i fixnum } ;
dup -18 shift bitxor ; inline
: next-index ( mt -- i )
- dup i>> dup mt-n < [ nip ] [ drop mt-generate 0 ] if ; inline
+ dup i>> dup n < [ nip ] [ drop mt-generate 0 ] if ; inline
PRIVATE>
@@ -75,7 +66,7 @@ M: mersenne-twister seed-random ( mt seed -- )
M: mersenne-twister random-32* ( mt -- r )
[ next-index ]
- [ seq>> wrap-nth mt-temper ]
+ [ seq>> nth-unsafe mt-temper ]
[ [ 1+ ] change-i drop ] tri ;
USE: init
From fa146b248a01f33d0d1191d4e872cdae3feff13f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 5 Dec 2008 02:11:50 -0600
Subject: [PATCH 05/72] Remove obsolete info; 1+ and 1- are identical to 1 +
and 1 - in reality
---
core/math/math-docs.factor | 6 ++++--
1 file changed, 4 insertions(+), 2 deletions(-)
diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor
index aca43add5c..3c2b7f67e2 100644
--- a/core/math/math-docs.factor
+++ b/core/math/math-docs.factor
@@ -166,15 +166,17 @@ HELP: log2
HELP: 1+
{ $values { "x" number } { "y" number } }
{ $description
- "Increments a number by 1. The following two lines are equivalent, but the first is more efficient:"
+ "Increments a number by 1. The following two lines are equivalent:"
{ $code "1+" "1 +" }
+ "There is no difference in behavior or efficiency."
} ;
HELP: 1-
{ $values { "x" number } { "y" number } }
{ $description
- "Decrements a number by 1. The following two lines are equivalent, but the first is more efficient:"
+ "Decrements a number by 1. The following two lines are equivalent:"
{ $code "1-" "1 -" }
+ "There is no difference in behavior or efficiency."
} ;
HELP: ?1+
From 252b1eb5134937a87ecbf4c8e4e6e9dff326d621 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 5 Dec 2008 06:37:19 -0600
Subject: [PATCH 06/72] Faster conversion of sbufs, vectors and byte-vectors to
their corresponding fixed-size type respectively; we call the resize-T
primitive on the underlying sequence instead of >T
---
core/arrays/arrays.factor | 2 --
core/byte-arrays/byte-arrays.factor | 1 -
core/byte-vectors/byte-vectors.factor | 15 ++++++++++++++-
core/sbufs/sbufs.factor | 16 ++++++++--------
core/vectors/vectors.factor | 16 +++++++++++++++-
5 files changed, 37 insertions(+), 13 deletions(-)
diff --git a/core/arrays/arrays.factor b/core/arrays/arrays.factor
index 74bc57e9db..157ac013e3 100644
--- a/core/arrays/arrays.factor
+++ b/core/arrays/arrays.factor
@@ -16,8 +16,6 @@ M: object new-sequence drop f <array> ;
M: f new-sequence drop dup zero? [ drop f ] [ f <array> ] if ;
-M: array like drop dup array? [ >array ] unless ;
-
M: array equal?
over array? [ sequence= ] [ 2drop f ] if ;
diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor
index 50ea4b32ba..f981e758d7 100644
--- a/core/byte-arrays/byte-arrays.factor
+++ b/core/byte-arrays/byte-arrays.factor
@@ -9,7 +9,6 @@ M: byte-array length length>> ;
M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ;
M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ;
: >byte-array ( seq -- byte-array ) B{ } clone-like ; inline
-M: byte-array like drop dup byte-array? [ >byte-array ] unless ;
M: byte-array new-sequence drop <byte-array> ;
M: byte-array equal?
diff --git a/core/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor
index 5d337cb028..6938d02b2f 100644
--- a/core/byte-vectors/byte-vectors.factor
+++ b/core/byte-vectors/byte-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 byte-arrays ;
+sequences.private growable byte-arrays accessors ;
IN: byte-vectors
TUPLE: byte-vector
@@ -26,6 +26,19 @@ M: byte-vector new-sequence
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 <byte-vector> ;
INSTANCE: byte-vector growable
diff --git a/core/sbufs/sbufs.factor b/core/sbufs/sbufs.factor
index 5a30654f03..5590432ef4 100644
--- a/core/sbufs/sbufs.factor
+++ b/core/sbufs/sbufs.factor
@@ -31,16 +31,16 @@ M: sbuf equal?
M: string new-resizable drop <sbuf> ;
M: string like
+ #! If we have a string, we're done.
+ #! If we have an sbuf, and it's at full capacity, we're done.
+ #! Otherwise, call resize-string, which is a relatively
+ #! fast primitive.
drop dup string? [
dup sbuf? [
- dup length over underlying>> length eq? [
- underlying>> dup reset-string-hashcode
- ] [
- >string
- ] if
- ] [
- >string
- ] if
+ [ length ] [ underlying>> ] bi
+ 2dup length eq?
+ [ nip dup reset-string-hashcode ] [ resize-string ] if
+ ] [ >string ] if
] unless ;
INSTANCE: sbuf growable
diff --git a/core/vectors/vectors.factor b/core/vectors/vectors.factor
index dab30f306f..b4cade44db 100644
--- a/core/vectors/vectors.factor
+++ b/core/vectors/vectors.factor
@@ -1,6 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math sequences sequences.private growable ;
+USING: arrays kernel math sequences sequences.private growable
+accessors ;
IN: vectors
TUPLE: vector
@@ -22,6 +23,19 @@ M: vector new-sequence
M: vector equal?
over vector? [ sequence= ] [ 2drop f ] if ;
+M: array like
+ #! If we have an array, we're done.
+ #! If we have a vector, and it's at full capacity, we're done.
+ #! Otherwise, call resize-array, which is a relatively
+ #! fast primitive.
+ drop dup array? [
+ dup vector? [
+ [ length ] [ underlying>> ] bi
+ 2dup length eq?
+ [ nip ] [ resize-array ] if
+ ] [ >array ] if
+ ] unless ;
+
M: sequence new-resizable drop <vector> ;
INSTANCE: vector growable
From e256846acd7608532c0ca686b92e2842b18a0401 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 5 Dec 2008 06:38:51 -0600
Subject: [PATCH 07/72] Tweak string representation; high bit indicates if
character has high bits in aux vector. Avoids memory access in common case.
Split set-string-nth into two primitives; set-string-nth-fast is open-coded
by optimizing compiler. 13% improvement on reverse-complement
---
basis/bootstrap/image/image.factor | 5 ++
basis/compiler/cfg/def-use/def-use.factor | 2 +
.../cfg/instructions/instructions.factor | 1 +
.../compiler/cfg/intrinsics/intrinsics.factor | 2 +
.../cfg/intrinsics/slots/slots.factor | 4 +
basis/compiler/codegen/codegen.factor | 8 ++
basis/cpu/architecture/architecture.factor | 1 +
basis/cpu/x86/x86.factor | 23 ++++-
.../known-words/known-words.factor | 3 +-
core/bootstrap/primitives.factor | 3 +-
core/strings/strings.factor | 11 ++-
vm/primitives.c | 3 +-
vm/types.c | 84 ++++++++++++-------
vm/types.h | 3 +-
14 files changed, 113 insertions(+), 40 deletions(-)
diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor
index f352a4a254..380c9b2348 100644
--- a/basis/bootstrap/image/image.factor
+++ b/basis/bootstrap/image/image.factor
@@ -351,7 +351,12 @@ M: wrapper '
: pad-bytes ( seq -- newseq )
dup length bootstrap-cell align 0 pad-right ;
+: check-string ( string -- )
+ [ 127 > ] contains?
+ [ "Bootstrap cannot emit non-ASCII strings" throw ] when ;
+
: emit-string ( string -- ptr )
+ dup check-string
string type-number object tag-number [
dup length emit-fixnum
f ' emit
diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor
index 3825ae480e..068a6a6377 100644
--- a/basis/compiler/cfg/def-use/def-use.factor
+++ b/basis/compiler/cfg/def-use/def-use.factor
@@ -15,6 +15,7 @@ M: ##dispatch defs-vregs temp>> 1array ;
M: ##slot defs-vregs dst/tmp-vregs ;
M: ##set-slot defs-vregs temp>> 1array ;
M: ##string-nth defs-vregs dst/tmp-vregs ;
+M: ##set-string-nth-fast defs-vregs temp>> 1array ;
M: ##compare defs-vregs dst/tmp-vregs ;
M: ##compare-imm defs-vregs dst/tmp-vregs ;
M: ##compare-float defs-vregs dst/tmp-vregs ;
@@ -31,6 +32,7 @@ M: ##slot-imm uses-vregs obj>> 1array ;
M: ##set-slot uses-vregs [ src>> ] [ obj>> ] [ slot>> ] tri 3array ;
M: ##set-slot-imm uses-vregs [ src>> ] [ obj>> ] bi 2array ;
M: ##string-nth uses-vregs [ obj>> ] [ index>> ] bi 2array ;
+M: ##set-string-nth-fast uses-vregs [ src>> ] [ obj>> ] [ index>> ] tri 3array ;
M: ##conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: ##compare-imm-branch uses-vregs src1>> 1array ;
M: ##dispatch uses-vregs src>> 1array ;
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 62d4990c92..2e7e044739 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -73,6 +73,7 @@ INSN: ##set-slot-imm < ##write { obj vreg } { slot integer } { tag integer } ;
! String element access
INSN: ##string-nth < ##flushable { obj vreg } { index vreg } { temp vreg } ;
+INSN: ##set-string-nth-fast < ##effect { obj vreg } { index vreg } { temp vreg } ;
! Integer arithmetic
INSN: ##add < ##commutative ;
diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor
index aaa45c3937..cfc04fa036 100644
--- a/basis/compiler/cfg/intrinsics/intrinsics.factor
+++ b/basis/compiler/cfg/intrinsics/intrinsics.factor
@@ -45,6 +45,7 @@ IN: compiler.cfg.intrinsics
slots.private:slot
slots.private:set-slot
strings.private:string-nth
+ strings.private:set-string-nth-fast
classes.tuple.private:<tuple-boa>
arrays:<array>
byte-arrays:<byte-array>
@@ -126,6 +127,7 @@ IN: compiler.cfg.intrinsics
{ \ slots.private:slot [ emit-slot iterate-next ] }
{ \ slots.private:set-slot [ emit-set-slot iterate-next ] }
{ \ strings.private:string-nth [ drop emit-string-nth iterate-next ] }
+ { \ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast iterate-next ] }
{ \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> iterate-next ] }
{ \ arrays:<array> [ emit-<array> iterate-next ] }
{ \ byte-arrays:<byte-array> [ emit-<byte-array> iterate-next ] }
diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor
index fec234a576..60ae1d2d0a 100644
--- a/basis/compiler/cfg/intrinsics/slots/slots.factor
+++ b/basis/compiler/cfg/intrinsics/slots/slots.factor
@@ -54,3 +54,7 @@ IN: compiler.cfg.intrinsics.slots
: emit-string-nth ( -- )
2inputs swap ^^untag-fixnum ^^string-nth ^^tag-fixnum ds-push ;
+
+: emit-set-string-nth-fast ( -- )
+ 3inputs [ ^^untag-fixnum ] [ ^^untag-fixnum ] [ ] tri*
+ swap i ##set-string-nth-fast ;
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 2161c8b091..96db72c6ea 100644
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -131,6 +131,14 @@ M: ##string-nth generate-insn
[ temp>> register ]
} cleave %string-nth ;
+M: ##set-string-nth-fast generate-insn
+ {
+ [ src>> register ]
+ [ obj>> register ]
+ [ index>> register ]
+ [ temp>> register ]
+ } cleave %set-string-nth-fast ;
+
: dst/src ( insn -- dst src )
[ dst>> register ] [ src>> register ] bi ; inline
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index 12b6809df9..eb93a8dbb5 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -59,6 +59,7 @@ HOOK: %set-slot cpu ( src obj slot tag temp -- )
HOOK: %set-slot-imm cpu ( src obj slot tag -- )
HOOK: %string-nth cpu ( dst obj index temp -- )
+HOOK: %set-string-nth-fast cpu ( ch obj index temp -- )
HOOK: %add cpu ( dst src1 src2 -- )
HOOK: %add-imm cpu ( dst src1 src2 -- )
diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index 3dbcd2eabf..d7234eb389 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -365,23 +365,38 @@ M:: x86 %box-alien ( dst src temp -- )
M:: x86 %string-nth ( dst src index temp -- )
"end" define-label
dst { src index temp } [| new-dst |
+ ! Load the least significant 7 bits into new-dst.
+ ! 8th bit indicates whether we have to load from
+ ! the aux vector or not.
temp src index [+] LEA
new-dst 1 small-reg temp string-offset [+] MOV
new-dst new-dst 1 small-reg MOVZX
+ ! Do we have to look at the aux vector?
+ new-dst HEX: 80 CMP
+ "end" get JL
+ ! Yes, this is a non-ASCII character. Load aux vector
temp src string-aux-offset [+] MOV
- temp \ f tag-number CMP
- "end" get JE
new-dst temp XCHG
+ ! Compute index
new-dst index ADD
new-dst index ADD
+ ! Load high 16 bits
new-dst 2 small-reg new-dst byte-array-offset [+] MOV
new-dst new-dst 2 small-reg MOVZX
- new-dst 8 SHL
- new-dst temp OR
+ new-dst 7 SHL
+ ! Compute code point
+ new-dst temp XOR
"end" resolve-label
dst new-dst ?MOV
] with-small-register ;
+M:: x86 %set-string-nth-fast ( ch str index temp -- )
+ ch { index str } [| new-ch |
+ new-ch ch ?MOV
+ temp str index [+] LEA
+ temp string-offset [+] new-ch 1 small-reg MOV
+ ] with-small-register ;
+
:: %alien-integer-getter ( dst src size quot -- )
dst { src } [| new-dst |
new-dst dup size small-reg dup src [] MOV
diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index 26e1b81c93..2cb3d1f006 100644
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -562,7 +562,8 @@ M: object infer-call*
\ string-nth { fixnum string } { fixnum } define-primitive
\ string-nth make-flushable
-\ set-string-nth { fixnum fixnum string } { } define-primitive
+\ set-string-nth-slow { fixnum fixnum string } { } define-primitive
+\ set-string-nth-fast { fixnum fixnum string } { } define-primitive
\ resize-array { integer array } { array } define-primitive
\ resize-array make-flushable
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index a4cee5c7b9..0a7e5fe233 100644
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -499,7 +499,8 @@ tuple
{ "alien-address" "alien" }
{ "set-slot" "slots.private" }
{ "string-nth" "strings.private" }
- { "set-string-nth" "strings.private" }
+ { "set-string-nth-fast" "strings.private" }
+ { "set-string-nth-slow" "strings.private" }
{ "resize-array" "arrays" }
{ "resize-string" "strings" }
{ "<array>" "arrays" }
diff --git a/core/strings/strings.factor b/core/strings/strings.factor
index 39628ede98..0c3f918fdc 100644
--- a/core/strings/strings.factor
+++ b/core/strings/strings.factor
@@ -16,6 +16,10 @@ IN: strings
: rehash-string ( str -- )
1 over sequence-hashcode swap set-string-hashcode ; inline
+: set-string-nth ( ch n str -- )
+ pick HEX: 7f fixnum<=
+ [ set-string-nth-fast ] [ set-string-nth-slow ] if ; inline
+
PRIVATE>
M: string equal?
@@ -27,8 +31,9 @@ M: string equal?
] if ;
M: string hashcode*
- nip dup string-hashcode [ ]
- [ dup rehash-string string-hashcode ] ?if ;
+ nip
+ dup string-hashcode
+ [ ] [ dup rehash-string string-hashcode ] ?if ;
M: string length
length>> ;
@@ -38,7 +43,7 @@ M: string nth-unsafe
M: string set-nth-unsafe
dup reset-string-hashcode
- [ [ >fixnum ] dip >fixnum ] dip set-string-nth ;
+ [ >fixnum ] [ >fixnum ] [ ] tri* set-string-nth ;
M: string clone
(clone) [ clone ] change-aux ;
diff --git a/vm/primitives.c b/vm/primitives.c
index 135d5478ea..a01a8653b7 100755
--- a/vm/primitives.c
+++ b/vm/primitives.c
@@ -105,7 +105,8 @@ void *primitives[] = {
primitive_alien_address,
primitive_set_slot,
primitive_string_nth,
- primitive_set_string_nth,
+ primitive_set_string_nth_fast,
+ primitive_set_string_nth_slow,
primitive_resize_array,
primitive_resize_string,
primitive_array,
diff --git a/vm/types.c b/vm/types.c
index d6e78013cb..a614011e7e 100755
--- a/vm/types.c
+++ b/vm/types.c
@@ -328,43 +328,62 @@ void primitive_tuple_boa(void)
/* Strings */
CELL string_nth(F_STRING* string, CELL index)
{
+ /* If high bit is set, the most significant 16 bits of the char
+ come from the aux vector. The least significant bit of the
+ corresponding aux vector entry is negated, so that we can
+ XOR the two components together and get the original code point
+ back. */
CELL ch = bget(SREF(string,index));
- if(string->aux == F)
+ if((ch & 0x80) == 0)
return ch;
else
{
F_BYTE_ARRAY *aux = untag_object(string->aux);
- return (cget(BREF(aux,index * sizeof(u16))) << 8) | ch;
+ return (cget(BREF(aux,index * sizeof(u16))) << 7) ^ ch;
}
}
-/* allocates memory */
-void set_string_nth(F_STRING* string, CELL index, CELL value)
+void set_string_nth_fast(F_STRING* string, CELL index, CELL ch)
{
- bput(SREF(string,index),value & 0xff);
+ bput(SREF(string,index),ch);
+}
+void set_string_nth_slow(F_STRING* string, CELL index, CELL ch)
+{
F_BYTE_ARRAY *aux;
+ bput(SREF(string,index),(ch & 0x7f) | 0x80);
+
if(string->aux == F)
{
- if(value <= 0xff)
- return;
- else
- {
- REGISTER_UNTAGGED(string);
- aux = allot_byte_array(
- untag_fixnum_fast(string->length)
- * sizeof(u16));
- UNREGISTER_UNTAGGED(string);
+ REGISTER_UNTAGGED(string);
+ /* We don't need to pre-initialize the
+ byte array with any data, since we
+ only ever read from the aux vector
+ if the most significant bit of a
+ character is set. Initially all of
+ the bits are clear. */
+ aux = allot_byte_array_internal(
+ untag_fixnum_fast(string->length)
+ * sizeof(u16));
+ UNREGISTER_UNTAGGED(string);
- write_barrier((CELL)string);
- string->aux = tag_object(aux);
- }
+ write_barrier((CELL)string);
+ string->aux = tag_object(aux);
}
else
aux = untag_object(string->aux);
- cput(BREF(aux,index * sizeof(u16)),value >> 8);
+ cput(BREF(aux,index * sizeof(u16)),(ch >> 7) ^ 1);
+}
+
+/* allocates memory */
+void set_string_nth(F_STRING* string, CELL index, CELL ch)
+{
+ if(ch <= 0x7f)
+ set_string_nth_fast(string,index,ch);
+ else
+ set_string_nth_slow(string,index,ch);
}
/* untagged */
@@ -382,17 +401,8 @@ F_STRING* allot_string_internal(CELL capacity)
/* allocates memory */
void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill)
{
- if(fill == 0)
- {
- memset((void *)SREF(string,start),'\0',capacity - start);
-
- if(string->aux != F)
- {
- F_BYTE_ARRAY *aux = untag_object(string->aux);
- memset((void *)BREF(aux,start * sizeof(u16)),'\0',
- (capacity - start) * sizeof(u16));
- }
- }
+ if(fill <= 0x7f)
+ memset((void *)SREF(string,start),fill,capacity - start);
else
{
CELL i;
@@ -572,3 +582,19 @@ void primitive_set_string_nth(void)
CELL value = untag_fixnum_fast(dpop());
set_string_nth(string,index,value);
}
+
+void primitive_set_string_nth_fast(void)
+{
+ F_STRING *string = untag_object(dpop());
+ CELL index = untag_fixnum_fast(dpop());
+ CELL value = untag_fixnum_fast(dpop());
+ set_string_nth_fast(string,index,value);
+}
+
+void primitive_set_string_nth_slow(void)
+{
+ F_STRING *string = untag_object(dpop());
+ CELL index = untag_fixnum_fast(dpop());
+ CELL value = untag_fixnum_fast(dpop());
+ set_string_nth_slow(string,index,value);
+}
diff --git a/vm/types.h b/vm/types.h
index 47747547db..242939c502 100755
--- a/vm/types.h
+++ b/vm/types.h
@@ -152,7 +152,8 @@ CELL string_nth(F_STRING* string, CELL index);
void set_string_nth(F_STRING* string, CELL index, CELL value);
void primitive_string_nth(void);
-void primitive_set_string_nth(void);
+void primitive_set_string_nth_slow(void);
+void primitive_set_string_nth_fast(void);
F_WORD *allot_word(CELL vocab, CELL name);
void primitive_word(void);
From 8db24bdd34b6de9c5b20389e50f7a4491e565991 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 5 Dec 2008 08:25:26 -0600
Subject: [PATCH 08/72] 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: <continuation>
{ $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 )
<PRIVATE
diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor
index 5ee12ddedc..01ef8d480d 100644
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@@ -887,6 +887,11 @@ $nl
"An object can be cloned; the clone has distinct identity but equal value:"
{ $subsection clone } ;
+ARTICLE: "assertions" "Assertions"
+"Some words to make assertions easier to enforce:"
+{ $subsection assert }
+{ $subsection assert= } ;
+
ARTICLE: "dataflow" "Data and control flow"
{ $subsection "evaluator" }
{ $subsection "words" }
@@ -902,6 +907,7 @@ ARTICLE: "dataflow" "Data and control flow"
{ $subsection "compositional-combinators" }
{ $subsection "combinators" }
"Advanced topics:"
+{ $subsection "assertions" }
{ $subsection "implementing-combinators" }
{ $subsection "errors" }
{ $subsection "continuations" } ;
diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor
index 1e93a762f2..cc97b78eb6 100644
--- a/core/parser/parser-tests.factor
+++ b/core/parser/parser-tests.factor
@@ -5,6 +5,8 @@ sorting classes.tuple compiler.units debugger vocabs
vocabs.loader accessors eval combinators lexer ;
IN: parser.tests
+\ run-file must-infer
+
[
[ 1 [ 2 [ 3 ] 4 ] 5 ]
[ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval ]
@@ -400,7 +402,7 @@ IN: parser.tests
] times
[ "resource:core/parser/test/assert-depth.factor" run-file ]
-[ stack>> { 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 <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 5 Dec 2008 09:03:55 -0600
Subject: [PATCH 09/72] 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 <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 5 Dec 2008 09:04:02 -0600
Subject: [PATCH 10/72] 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 <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 5 Dec 2008 09:04:16 -0600
Subject: [PATCH 11/72] 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>
: <thread> ( 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 <c-reader>
From 29aeb707c1b044bdbf46aeccaa1e6781f59c24a3 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 5 Dec 2008 11:35:10 -0600
Subject: [PATCH 12/72] 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 <doug.coleman@gmail.com>
Date: Fri, 5 Dec 2008 11:36:41 -0600
Subject: [PATCH 13/72] 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: - <string> ; foldable
+: multiline-header ( -- string ) 20 CHAR: - <string> ; foldable
: (write-message) ( msg name>> level multi? -- )
[
From 320f3555419b5e94a0a4770c3490de468c7e88c1 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 5 Dec 2008 11:39:24 -0600
Subject: [PATCH 14/72] 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 <doug.coleman@gmail.com>
Date: Fri, 5 Dec 2008 12:53:23 -0600
Subject: [PATCH 15/72] 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 <doug.coleman@gmail.com>
Date: Fri, 5 Dec 2008 12:57:36 -0600
Subject: [PATCH 16/72] 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 <thread> } " 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" <jao@gnu.org>
Date: Sat, 6 Dec 2008 04:34:25 +0100
Subject: [PATCH 17/72] 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 <jao@gnu.org>
+Eduardo Cavazos <wayo.cavazos@gmail.com>
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
+
+! <PRIVATE
+
+TUPLE: fuel-status in use ds? ;
+
+SYMBOL: fuel-status-stack
+V{ } clone fuel-status-stack set-global
+
+: push-fuel-status ( -- )
+ in get use get clone display-stacks? get
+ 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 ] 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 "<path/to/factor/installation>/misc/fuel/fu.el")
+
+or
+
+ (add-to-list load-path "<path/to/factor/installation>/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 "<path/to/factor/installation>/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 <x> accept also C-<x> (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 <jao@gnu.org>
+;; 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 <jao@gnu.org>
+;; 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 <jao@gnu.org>
+;; 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 <jao@gnu.org>
+;; 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 <jao@gnu.org>
+;; 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 (<foo>)")
+ (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 <jao@gnu.org>
+;; 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 <jao@gnu.org>
+;; 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 <jao@gnu.org>
+;; 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 <jao@gnu.org>
+;; 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
+ '("{" "}" "^:" "^::" ";" "<<" "<PRIVATE" ">>"
+ "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>" "<PRIVATE"
+ "SINGLETON:" "SYMBOL:" "USE:" "VAR:"))))
+
+(defconst fuel-syntax--begin-of-def-regex
+ (format "^USING: \\|\\(%s\\)\\|\\(%s .*\\)"
+ fuel-syntax--definition-start-regex
+ fuel-syntax--single-liner-regex))
+
+(defconst fuel-syntax--end-of-def-line-regex
+ (format "^.*%s" fuel-syntax--definition-end-regex))
+
+(defconst fuel-syntax--end-of-def-regex
+ (format "\\(%s\\)\\|\\(%s .*\\)"
+ fuel-syntax--end-of-def-line-regex
+ fuel-syntax--single-liner-regex))
+
+;;; Factor syntax table
+
+(defvar fuel-syntax--syntax-table
+ (let ((i 0)
+ (table (make-syntax-table)))
+ ;; Default is atom-constituent
+ (while (< i 256)
+ (modify-syntax-entry i "_ " table)
+ (setq i (1+ i)))
+
+ ;; Word components.
+ (setq i ?0)
+ (while (<= i ?9)
+ (modify-syntax-entry i "w " table)
+ (setq i (1+ i)))
+ (setq i ?A)
+ (while (<= i ?Z)
+ (modify-syntax-entry i "w " table)
+ (setq i (1+ i)))
+ (setq i ?a)
+ (while (<= i ?z)
+ (modify-syntax-entry i "w " table)
+ (setq i (1+ i)))
+
+ ;; Whitespace
+ (modify-syntax-entry ?\t " " table)
+ (modify-syntax-entry ?\f " " table)
+ (modify-syntax-entry ?\r " " table)
+ (modify-syntax-entry ? " " table)
+
+ ;; (end of) Comments
+ (modify-syntax-entry ?\n ">" 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 <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 5 Dec 2008 23:51:34 -0600
Subject: [PATCH 18/72] 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 <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 5 Dec 2008 23:51:58 -0600
Subject: [PATCH 19/72] 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] <class/interval-info>
+] "outputs" set-word-prop
+
{
alien-signed-1
alien-unsigned-1
From 82cf6530c61e2b30180d6309cd0dcf185a4e48fa Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 5 Dec 2008 23:52:09 -0600
Subject: [PATCH 20/72] 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 <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 5 Dec 2008 23:52:47 -0600
Subject: [PATCH 21/72] 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" ;
+
<PRIVATE
+: ascii? ( ch -- ? ) 0 127 between? ; inline
+
+: tr-nth ( n mapping -- ch ) nth-unsafe 127 bitand ; inline
+
+: check-tr ( from to -- )
+ [ [ ascii? ] all? ] both? [ bad-tr ] unless ;
+
: compute-tr ( quot from to -- mapping )
- zip [ 256 ] 2dip '[ [ @ _ at ] keep or ] B{ } map-as ; inline
+ zip [ 128 ] 2dip '[ [ @ _ at ] keep or ] B{ } map-as ; inline
: tr-hints ( word -- )
{ { byte-array } { string } } "specializer" set-word-prop ;
@@ -16,13 +28,13 @@ IN: tr
create-in dup tr-hints ;
: tr-quot ( mapping -- quot )
- '[ [ dup 0 255 between? [ _ nth-unsafe ] when ] map ] ;
+ '[ [ dup ascii? [ _ tr-nth ] when ] map ] ;
: define-tr ( word mapping -- )
tr-quot (( seq -- translated )) define-declared ;
: fast-tr-quot ( mapping -- quot )
- '[ [ _ nth-unsafe ] change-each ] ;
+ '[ [ _ tr-nth ] change-each ] ;
: define-fast-tr ( word mapping -- )
fast-tr-quot (( seq -- )) define-declared ;
@@ -32,6 +44,7 @@ PRIVATE>
: 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 <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 5 Dec 2008 23:53:16 -0600
Subject: [PATCH 22/72] Use stack effect literals instead of <effect> 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 <effect> 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 <effect> 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" <jao@gnu.org>
Date: Sat, 6 Dec 2008 07:01:12 +0100
Subject: [PATCH 23/72] 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 <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 6 Dec 2008 00:12:07 -0600
Subject: [PATCH 24/72] 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 <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 6 Dec 2008 00:20:49 -0600
Subject: [PATCH 25/72] 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" <jao@gnu.org>
Date: Sat, 6 Dec 2008 07:34:11 +0100
Subject: [PATCH 26/72] 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 <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 6 Dec 2008 01:36:25 -0600
Subject: [PATCH 27/72] 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 <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 6 Dec 2008 03:47:10 -0600
Subject: [PATCH 28/72] 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 <jao@gnu.org>
-Eduardo Cavazos <wayo.cavazos@gmail.com>
+Jose Antonio Ortega Ruiz
+Eduardo Cavazos
From e95bda8144058c374215fb7ac9ad29305f7d03c1 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 6 Dec 2008 03:47:17 -0600
Subject: [PATCH 29/72] 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 a56d480aa69e74465d64fc0b37b381a24e2fa9f3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 6 Dec 2008 09:16:29 -0600
Subject: [PATCH 30/72] 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 <literal-info> 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 <byte> 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 <byte> 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*
\ <complex> { real real } { complex } define-primitive
\ <complex> 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> 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 <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 6 Dec 2008 11:17:19 -0600
Subject: [PATCH 31/72] 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 <vector> [ (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>> <flipped> ] [ 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>> \ <complex> 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>> <flipped> ] [ 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>> <flipped> ]
- [ phi-info-d>> <flipped> ] 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>> <flipped> ] [ 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-<complex> ( #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 <vector> [ (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 <vector> [
+ 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.
+<PRIVATE
+
+: generic-flip ( matrix -- newmatrix )
+ [ dup first length [ length min ] reduce ] keep
+ [ [ nth-unsafe ] with { } map-as ] curry { } map-as ; inline
+
+USE: arrays
+
+: array-length ( array -- len )
+ { array } declare length>> ;
+
+: 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 <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 6 Dec 2008 14:24:31 -0600
Subject: [PATCH 32/72] 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 <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 6 Dec 2008 14:24:44 -0600
Subject: [PATCH 33/72] 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 <dharmatech@finkelstein.stackeffects.info>
Date: Sat, 6 Dec 2008 15:03:02 -0600
Subject: [PATCH 34/72] 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 <dharmatech@finkelstein.stackeffects.info>
Date: Sat, 6 Dec 2008 15:12:59 -0600
Subject: [PATCH 35/72] 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 <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 6 Dec 2008 15:30:40 -0600
Subject: [PATCH 36/72] 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 <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 6 Dec 2008 15:31:17 -0600
Subject: [PATCH 37/72] 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 <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 6 Dec 2008 15:31:35 -0600
Subject: [PATCH 38/72] 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 <hash-array> >>array init-hash ;
+ swap <hash-array> >>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 <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 6 Dec 2008 16:57:28 -0600
Subject: [PATCH 39/72] 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 <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 6 Dec 2008 17:35:04 -0600
Subject: [PATCH 40/72] 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: <CFNumber> ( number -- alien )
+
M: integer <CFNumber>
[ f kCFNumberLongLongType ] dip <longlong> CFNumberCreate ;
+
M: float <CFNumber>
[ f kCFNumberDoubleType ] dip <double> CFNumberCreate ;
+
M: t <CFNumber>
drop f kCFNumberIntType 1 <int> CFNumberCreate ;
+
M: f <CFNumber>
drop f kCFNumberIntType 0 <int> CFNumberCreate ;
: <CFData> ( 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 <CFBundle> [
CFBundleLoadExecutable drop
@@ -141,8 +162,11 @@ M: f <CFNumber>
] ?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 <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 6 Dec 2008 17:35:15 -0600
Subject: [PATCH 41/72] 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" <c-array> >>events ;
+ max-events "kevent" <struct-array> >>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" <c-object>
- 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" <c-object>
- 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" <c-object>
- 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 ;
-
-: <vnode-monitor> ( 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 <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 6 Dec 2008 17:45:41 -0600
Subject: [PATCH 42/72] 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 <doug.coleman@gmail.com>
Date: Sat, 6 Dec 2008 18:25:35 -0600
Subject: [PATCH 43/72] 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 <void*> 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 <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 6 Dec 2008 18:37:28 -0600
Subject: [PATCH 44/72] 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 <array> ;
+M: object new-sequence drop 0 <array> ;
-M: f new-sequence drop dup zero? [ drop f ] [ f <array> ] if ;
+M: f new-sequence drop dup zero? [ drop f ] [ 0 <array> ] 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 } ;
-: <vector> ( n -- vector ) f <array> 0 vector boa ; inline
+: <vector> ( n -- vector ) 0 <array> 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 <doug.coleman@gmail.com>
Date: Sat, 6 Dec 2008 18:41:13 -0600
Subject: [PATCH 45/72] 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
<PRIVATE
-: short ( seq n -- seq n )
- over length min ;
-
: next ( seq -- )
[ 4 short tail* sum ] keep push ;
From 37b9a350cc47f514d46d77833f243af1faf6e6cd Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 6 Dec 2008 18:42:41 -0600
Subject: [PATCH 46/72] 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 <word> 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 <doug.coleman@gmail.com>
Date: Sat, 6 Dec 2008 18:58:05 -0600
Subject: [PATCH 47/72] 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' [ \"<strong>\" swap \"</strong>\" 3append ] <@ parse-1 ." "\"<strong>foo</strong>\"" } ;
+{ $example "USING: kernel parser-combinators parser-combinators.simple prettyprint sequences ;" "\"*foo*\" 'bold' [ \"<strong>\" \"</strong>\" surround ] <@ parse-1 ." "\"<strong>foo</strong>\"" } ;
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' [ \"<emphasis>\" swap \"</emphasis>\" 3append ] <@ parse-1 ." "\"<emphasis>foo</emphasis>\"" } } ;
+{ $example "USING: kernel parser-combinators parser-combinators.simple prettyprint sequences ;" "\"_foo_\" 'italic' [ \"<emphasis>\" \"</emphasis>\" surround ] <@ parse-1 ." "\"<emphasis>foo</emphasis>\"" } } ;
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* ;
: <rollback-action> ( -- action )
<action>
From 14fb58f448c1f32c5e09b4407b9813e599cfe1be Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 6 Dec 2008 18:58:45 -0600
Subject: [PATCH 48/72] 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 <insert-user-assigned-statement> ( 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 <literal-bind> 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 ;
-: <foo> ( str -- <str> ) "<" swap ">" 3append ;
+: <foo> ( str -- <str> ) "<" ">" surround ;
: def-for-html-word-<foo> ( name -- )
#! Return the name and code for the <foo> patterned
@@ -49,14 +49,14 @@ SYMBOL: html
#! word.
foo> [ ">" write-html ] (( -- )) html-word ;
-: </foo> ( str -- </str> ) "</" swap ">" 3append ;
+: </foo> ( str -- </str> ) "</" ">" surround ;
: def-for-html-word-</foo> ( name -- )
#! Return the name and code for the </foo> patterned
#! word.
</foo> dup '[ _ write-html ] (( -- )) html-word ;
-: <foo/> ( str -- <str/> ) "<" swap "/>" 3append ;
+: <foo/> ( str -- <str/> ) "<" "/>" surround ;
: def-for-html-word-<foo/> ( name -- )
#! Return the name and code for the <foo/> 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
[ <deploy-gadget> 10 <border> ]
- [ "Deploying \"" swap "\"" 3append ] bi
+ [ "Deploying \"" "\"" surround ] bi
open-window ;
From ce6ed41cbe1ac97e3a7f75b88f4aa71617b8e1c0 Mon Sep 17 00:00:00 2001
From: Bruno Deferrari <utizoc@gmail.com>
Date: Sat, 6 Dec 2008 23:27:32 -0200
Subject: [PATCH 49/72] 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 <doug.coleman@gmail.com>
Date: Sat, 6 Dec 2008 22:58:19 -0600
Subject: [PATCH 50/72] 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
[ <byte-array> ] [ <uint> ] 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" <c-object>
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" <c-object> [ 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 <doug.coleman@gmail.com>
Date: Sat, 6 Dec 2008 23:01:17 -0600
Subject: [PATCH 51/72] 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 <doug.coleman@gmail.com>
Date: Sat, 6 Dec 2008 23:04:54 -0600
Subject: [PATCH 52/72] 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 <doug.coleman@gmail.com>
Date: Sat, 6 Dec 2008 23:05:02 -0600
Subject: [PATCH 53/72] 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 <doug.coleman@gmail.com>
Date: Sat, 6 Dec 2008 23:08:18 -0600
Subject: [PATCH 54/72] 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 <doug.coleman@gmail.com>
Date: Sat, 6 Dec 2008 23:12:38 -0600
Subject: [PATCH 55/72] 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 / <range> ;
: generate-simpson-weights ( seq -- seq )
- { 1 4 }
- swap length 2 / 2 - { 2 4 } <repetition> concat
- { 1 } 3append ;
+ length 2 / 2 - { 2 4 } <repetition> 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 <doug.coleman@gmail.com>
Date: Sat, 6 Dec 2008 23:38:04 -0600
Subject: [PATCH 56/72] 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 <doug.coleman@gmail.com>
Date: Sat, 6 Dec 2008 23:42:41 -0600
Subject: [PATCH 57/72] 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 <doug.coleman@gmail.com>
Date: Sun, 7 Dec 2008 01:36:10 -0600
Subject: [PATCH 58/72] 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 <doug.coleman@gmail.com>
Date: Sun, 7 Dec 2008 01:55:19 -0600
Subject: [PATCH 59/72] 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
+ <displaced-alien> 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
- <displaced-alien> 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 <doug.coleman@gmail.com>
Date: Sun, 7 Dec 2008 01:59:38 -0600
Subject: [PATCH 60/72] 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 <schlieper@unc.edu>
Date: Sun, 7 Dec 2008 04:06:52 -0500
Subject: [PATCH 61/72] 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 <doug.coleman@gmail.com>
Date: Sun, 7 Dec 2008 08:39:16 -0600
Subject: [PATCH 62/72] 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 <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 7 Dec 2008 08:50:59 -0600
Subject: [PATCH 63/72] 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 <groups>
2 over set-length
>array
From d1744fd67a707bd8d603f34c7aabdd0adc668948 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 7 Dec 2008 08:51:22 -0600
Subject: [PATCH 64/72] 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 <doug.coleman@gmail.com>
Date: Sun, 7 Dec 2008 17:21:15 -0600
Subject: [PATCH 65/72] 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 <doug.coleman@gmail.com>
Date: Sun, 7 Dec 2008 17:22:05 -0600
Subject: [PATCH 66/72] 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 <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 7 Dec 2008 19:44:49 -0600
Subject: [PATCH 67/72] 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 <class-info> ] "outputs" set-word-prop ] each
+
+{ (log2) fixnum-log2 bignum-log2 } [
+ [
+ [ class>> ] [ interval>> interval-log2 ] bi <class/interval-info>
+ ] "outputs" set-word-prop
+] each
+
\ string-nth [
2drop fixnum 0 23 2^ [a,b] <class/interval-info>
] "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 <doug.coleman@gmail.com>
Date: Sun, 7 Dec 2008 23:51:13 -0600
Subject: [PATCH 68/72] 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
<PRIVATE
: ls-time ( timestamp -- string )
[ hour>> ] [ 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 <doug.coleman@gmail.com>
Date: Mon, 8 Dec 2008 00:05:52 -0600
Subject: [PATCH 69/72] 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 <string-reader> r> state-parse ; inline
+ [ <string-reader> ] dip state-parse ; inline
From 90cdb6c4f4fc23b3e9c63591c3a5fcd5d22f8fa2 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 8 Dec 2008 00:10:24 -0600
Subject: [PATCH 70/72] 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 <mersenne-twister> r> with-random ;
+ [ <mersenne-twister> ] dip with-random ;
[ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test
From 7f93d335a656611cc656ebe6fd8bf576a82453f3 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 8 Dec 2008 20:10:52 -0600
Subject: [PATCH 71/72] 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 ;
+<PRIVATE
+
: qualified-directory ( path -- seq )
dup directory-files [ append-path ] with map ;
@@ -25,25 +27,32 @@ TUPLE: directory-iterator path bfs queue ;
[ over push-directory next-file ] [ nip ] if
] if ;
-: iterate-directory ( iter quot -- obj )
+: iterate-directory ( iter quot: ( obj -- ? ) -- obj )
over next-file [
over call
- [ 2drop ] [ iterate-directory ] if
+ [ 2nip ] [ iterate-directory ] if*
] [
2drop f
] if* ; inline recursive
-: find-file ( path bfs? quot -- path/f )
+PRIVATE>
+
+: find-file ( path bfs? quot: ( obj -- ? ) -- path/f )
[ <directory-iterator> ] dip
[ keep and ] curry iterate-directory ; inline
-: each-file ( path bfs? quot -- )
+: each-file ( path bfs? quot: ( obj -- ? ) -- )
[ <directory-iterator> ] dip
[ f ] compose iterate-directory drop ; inline
-: find-all-files ( path bfs? quot -- paths )
+: find-all-files ( path bfs? quot: ( obj -- ? ) -- paths )
[ <directory-iterator> ] 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 <doug.coleman@gmail.com>
Date: Mon, 8 Dec 2008 20:11:24 -0600
Subject: [PATCH 72/72] 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