Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
919a4393f5
|
|
@ -102,6 +102,8 @@ SYMBOL: bootstrap-time
|
|||
] if
|
||||
] [
|
||||
drop
|
||||
load-help? off
|
||||
"resource:basis/bootstrap/bootstrap-error.factor" run-file
|
||||
[
|
||||
load-help? off
|
||||
"resource:basis/bootstrap/bootstrap-error.factor" run-file
|
||||
] with-scope
|
||||
] recover
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax destructors accessors kernel ;
|
||||
USING: alien.syntax destructors accessors kernel calendar ;
|
||||
IN: core-foundation
|
||||
|
||||
TYPEDEF: void* CFTypeRef
|
||||
|
|
@ -30,3 +30,10 @@ M: CFRelease-destructor dispose* alien>> CFRelease ;
|
|||
|
||||
: |CFRelease ( alien -- alien )
|
||||
dup f CFRelease-destructor boa |dispose drop ; inline
|
||||
|
||||
: >CFTimeInterval ( duration -- interval )
|
||||
duration>seconds ; inline
|
||||
|
||||
: >CFAbsoluteTime ( timestamp -- time )
|
||||
T{ timestamp { year 2001 } { month 1 } { day 1 } } time-
|
||||
duration>seconds ; inline
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
! Copyright (C) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.syntax kernel namespaces core-foundation
|
||||
core-foundation.strings core-foundation.file-descriptors
|
||||
core-foundation.timers ;
|
||||
USING: accessors alien alien.syntax kernel math namespaces
|
||||
sequences destructors combinators threads heaps deques calendar
|
||||
core-foundation core-foundation.strings
|
||||
core-foundation.file-descriptors core-foundation.timers ;
|
||||
IN: core-foundation.run-loop
|
||||
|
||||
: kCFRunLoopRunFinished 1 ; inline
|
||||
|
|
@ -59,3 +60,80 @@ FUNCTION: void CFRunLoopRemoveTimer (
|
|||
"kCFRunLoopDefaultMode" <CFString>
|
||||
dup \ CFRunLoopDefaultMode set-global
|
||||
] when ;
|
||||
|
||||
TUPLE: run-loop fds sources timers ;
|
||||
|
||||
: <run-loop> ( -- run-loop )
|
||||
V{ } clone V{ } clone V{ } clone \ run-loop boa ;
|
||||
|
||||
SYMBOL: expiry-check
|
||||
|
||||
: run-loop ( -- run-loop )
|
||||
\ run-loop get-global not expiry-check get expired? or
|
||||
[
|
||||
31337 <alien> expiry-check set-global
|
||||
<run-loop> dup \ run-loop set-global
|
||||
] [ \ run-loop get-global ] if ;
|
||||
|
||||
: add-source-to-run-loop ( source -- )
|
||||
[ run-loop sources>> push ]
|
||||
[
|
||||
CFRunLoopGetMain
|
||||
swap CFRunLoopDefaultMode
|
||||
CFRunLoopAddSource
|
||||
] bi ;
|
||||
|
||||
: create-fd-source ( CFFileDescriptor -- source )
|
||||
f swap 0 CFFileDescriptorCreateRunLoopSource ;
|
||||
|
||||
: add-fd-to-run-loop ( fd callback -- )
|
||||
[
|
||||
<CFFileDescriptor> |CFRelease
|
||||
[ run-loop fds>> push ]
|
||||
[ create-fd-source |CFRelease add-source-to-run-loop ]
|
||||
bi
|
||||
] with-destructors ;
|
||||
|
||||
: add-timer-to-run-loop ( timer -- )
|
||||
[ run-loop timers>> push ]
|
||||
[
|
||||
CFRunLoopGetMain
|
||||
swap CFRunLoopDefaultMode
|
||||
CFRunLoopAddTimer
|
||||
] bi ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: ((reset-timer)) ( timer counter timestamp -- )
|
||||
nip >CFAbsoluteTime CFRunLoopTimerSetNextFireDate ;
|
||||
|
||||
: (reset-timer) ( timer counter -- )
|
||||
yield {
|
||||
{ [ dup 0 = ] [ now ((reset-timer)) ] }
|
||||
{ [ run-queue deque-empty? not ] [ 1- (reset-timer) ] }
|
||||
{ [ sleep-queue heap-empty? ] [ 5 minutes hence ((reset-timer)) ] }
|
||||
[ sleep-queue heap-peek nip micros>timestamp ((reset-timer)) ]
|
||||
} cond ;
|
||||
|
||||
: reset-timer ( timer -- )
|
||||
10 (reset-timer) ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: reset-run-loop ( -- )
|
||||
run-loop
|
||||
[ timers>> [ reset-timer ] each ]
|
||||
[ fds>> [ enable-all-callbacks ] each ] bi ;
|
||||
|
||||
: timer-callback ( -- callback )
|
||||
"void" { "CFRunLoopTimerRef" "void*" } "cdecl"
|
||||
[ 2drop reset-run-loop yield ] alien-callback ;
|
||||
|
||||
: init-thread-timer ( -- )
|
||||
timer-callback <CFTimer> add-timer-to-run-loop ;
|
||||
|
||||
: run-one-iteration ( us -- handled? )
|
||||
reset-run-loop
|
||||
CFRunLoopDefaultMode
|
||||
swap [ microseconds ] [ 5 minutes ] if* >CFTimeInterval
|
||||
t CFRunLoopRunInMode kCFRunLoopRunHandledSource = ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax system math kernel core-foundation ;
|
||||
USING: alien.syntax system math kernel core-foundation calendar ;
|
||||
IN: core-foundation.timers
|
||||
|
||||
TYPEDEF: void* CFRunLoopTimerRef
|
||||
|
|
@ -18,12 +18,16 @@ FUNCTION: CFRunLoopTimerRef CFRunLoopTimerCreate (
|
|||
) ;
|
||||
|
||||
: <CFTimer> ( callback -- timer )
|
||||
[ f millis 1000 /f 60 0 0 ] dip f CFRunLoopTimerCreate ;
|
||||
[ f now >CFAbsoluteTime 60 0 0 ] dip f CFRunLoopTimerCreate ;
|
||||
|
||||
FUNCTION: void CFRunLoopTimerInvalidate (
|
||||
CFRunLoopTimerRef timer
|
||||
) ;
|
||||
|
||||
FUNCTION: Boolean CFRunLoopTimerIsValid (
|
||||
CFRunLoopTimerRef timer
|
||||
) ;
|
||||
|
||||
FUNCTION: void CFRunLoopTimerSetNextFireDate (
|
||||
CFRunLoopTimerRef timer,
|
||||
CFAbsoluteTime fireDate
|
||||
|
|
|
|||
|
|
@ -1,14 +1,20 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: threads io.backend namespaces init math kernel ;
|
||||
IN: io.thread
|
||||
USING: threads io.backend namespaces init math ;
|
||||
|
||||
! The Cocoa UI backend stops the I/O thread and takes over
|
||||
! completely.
|
||||
SYMBOL: io-thread-running?
|
||||
|
||||
: io-thread ( -- )
|
||||
sleep-time io-multiplex yield ;
|
||||
|
||||
: start-io-thread ( -- )
|
||||
[ io-thread t ]
|
||||
"I/O wait" spawn-server
|
||||
\ io-thread set-global ;
|
||||
[ [ io-thread-running? get-global ] [ io-thread ] [ ] while ]
|
||||
"I/O wait" spawn drop ;
|
||||
|
||||
[ start-io-thread ] "io.thread" add-init-hook
|
||||
[
|
||||
t io-thread-running? set-global
|
||||
start-io-thread
|
||||
] "io.thread" add-init-hook
|
||||
|
|
|
|||
|
|
@ -1,5 +0,0 @@
|
|||
USING: io.unix.multiplexers.run-loop tools.test
|
||||
destructors ;
|
||||
IN: io.unix.multiplexers.run-loop.tests
|
||||
|
||||
[ ] [ <run-loop-mx> dispose ] unit-test
|
||||
|
|
@ -1,50 +1,27 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces math accessors threads alien locals
|
||||
destructors combinators io.unix.multiplexers
|
||||
USING: kernel arrays namespaces math accessors alien locals
|
||||
destructors system threads io.unix.multiplexers
|
||||
io.unix.multiplexers.kqueue core-foundation
|
||||
core-foundation.run-loop core-foundation.file-descriptors ;
|
||||
core-foundation.run-loop ;
|
||||
IN: io.unix.multiplexers.run-loop
|
||||
|
||||
TUPLE: run-loop-mx kqueue-mx fd source ;
|
||||
TUPLE: run-loop-mx kqueue-mx ;
|
||||
|
||||
: kqueue-callback ( -- callback )
|
||||
: file-descriptor-callback ( -- callback )
|
||||
"void" { "CFFileDescriptorRef" "CFOptionFlags" "void*" }
|
||||
"cdecl" [
|
||||
3drop
|
||||
0 mx get kqueue-mx>> wait-for-events
|
||||
mx get fd>> enable-all-callbacks
|
||||
reset-run-loop
|
||||
yield
|
||||
]
|
||||
alien-callback ;
|
||||
|
||||
SYMBOL: kqueue-run-loop-source
|
||||
|
||||
: create-kqueue-source ( fd -- source )
|
||||
f swap 0 CFFileDescriptorCreateRunLoopSource ;
|
||||
|
||||
: add-kqueue-to-run-loop ( mx -- )
|
||||
CFRunLoopGetMain swap source>> CFRunLoopDefaultMode CFRunLoopAddSource ;
|
||||
|
||||
: remove-kqueue-from-run-loop ( source -- )
|
||||
CFRunLoopGetMain swap source>> CFRunLoopDefaultMode CFRunLoopRemoveSource ;
|
||||
] alien-callback ;
|
||||
|
||||
: <run-loop-mx> ( -- mx )
|
||||
[
|
||||
<kqueue-mx> |dispose
|
||||
dup fd>> kqueue-callback <CFFileDescriptor> |dispose
|
||||
dup create-kqueue-source run-loop-mx boa
|
||||
dup add-kqueue-to-run-loop
|
||||
] with-destructors ;
|
||||
|
||||
M: run-loop-mx dispose
|
||||
[
|
||||
{
|
||||
[ fd>> &dispose drop ]
|
||||
[ source>> &dispose drop ]
|
||||
[ remove-kqueue-from-run-loop ]
|
||||
[ kqueue-mx>> &dispose drop ]
|
||||
} cleave
|
||||
dup fd>> file-descriptor-callback add-fd-to-run-loop
|
||||
run-loop-mx boa
|
||||
] with-destructors ;
|
||||
|
||||
M: run-loop-mx add-input-callback kqueue-mx>> add-input-callback ;
|
||||
|
|
@ -52,7 +29,5 @@ M: run-loop-mx add-output-callback kqueue-mx>> add-output-callback ;
|
|||
M: run-loop-mx remove-input-callbacks kqueue-mx>> remove-input-callbacks ;
|
||||
M: run-loop-mx remove-output-callbacks kqueue-mx>> remove-output-callbacks ;
|
||||
|
||||
M:: run-loop-mx wait-for-events ( us mx -- )
|
||||
mx fd>> enable-all-callbacks
|
||||
CFRunLoopDefaultMode us [ 1000000 /f ] [ 60 ] if* t CFRunLoopRunInMode
|
||||
kCFRunLoopRunHandledSource = [ 0 mx wait-for-events ] when ;
|
||||
M: run-loop-mx wait-for-events ( us mx -- )
|
||||
swap run-one-iteration [ 0 swap wait-for-events ] [ drop ] if ;
|
||||
|
|
|
|||
|
|
@ -61,12 +61,6 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
|
|||
! Quotation which coerces return value to required type
|
||||
return-prep-quot infer-quot-here ;
|
||||
|
||||
! Callbacks are registered in a global hashtable. If you clear
|
||||
! this hashtable, they will all be blown away by code GC, beware
|
||||
SYMBOL: callbacks
|
||||
|
||||
[ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook
|
||||
|
||||
: register-callback ( word -- ) callbacks get conjoin ;
|
||||
|
||||
: callback-bottom ( params -- )
|
||||
|
|
|
|||
|
|
@ -107,3 +107,8 @@ M: quit-responder call-responder*
|
|||
"tools.deploy.test.8" shake-and-bake
|
||||
run-temp-image
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"tools.deploy.test.9" shake-and-bake
|
||||
run-temp-image
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,14 +1,15 @@
|
|||
USING: tools.deploy.config ;
|
||||
H{
|
||||
{ deploy-threads? t }
|
||||
{ deploy-c-types? f }
|
||||
{ deploy-ui? f }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-word-defs? f }
|
||||
{ deploy-math? t }
|
||||
{ deploy-io 3 }
|
||||
{ deploy-unicode? f }
|
||||
{ deploy-name "tools.deploy.test.3" }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-ui? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-word-defs? f }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-threads? t }
|
||||
{ deploy-io 3 }
|
||||
{ deploy-math? t }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-c-types? f }
|
||||
}
|
||||
|
|
|
|||
|
|
@ -0,0 +1,10 @@
|
|||
USING: alien kernel math ;
|
||||
IN: tools.deploy.test.9
|
||||
|
||||
: callback-test ( -- callback )
|
||||
"int" { "int" } "cdecl" [ 1 + ] alien-callback ;
|
||||
|
||||
: indirect-test ( -- )
|
||||
10 callback-test "int" { "int" } "cdecl" alien-indirect 11 assert= ;
|
||||
|
||||
MAIN: indirect-test
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
USING: tools.deploy.config ;
|
||||
H{
|
||||
{ deploy-unicode? f }
|
||||
{ deploy-name "tools.deploy.test.9" }
|
||||
{ deploy-ui? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-word-defs? f }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-threads? f }
|
||||
{ deploy-io 1 }
|
||||
{ deploy-math? t }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-c-types? f }
|
||||
}
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tr arrays sequences io words generic system combinators
|
||||
vocabs.loader ;
|
||||
vocabs.loader kernel ;
|
||||
IN: tools.disassembler
|
||||
|
||||
GENERIC: disassemble ( obj -- )
|
||||
|
|
@ -18,8 +18,7 @@ M: word disassemble word-xt 2array disassemble ;
|
|||
|
||||
M: method-spec disassemble first2 method disassemble ;
|
||||
|
||||
cpu {
|
||||
{ x86.32 [ "tools.disassembler.udis" ] }
|
||||
{ x86.64 [ "tools.disassembler.udis" ] }
|
||||
{ ppc [ "tools.disassembler.gdb" ] }
|
||||
} case require
|
||||
cpu x86? os unix? and
|
||||
"tools.disassembler.udis"
|
||||
"tools.disassembler.gdb" ?
|
||||
require
|
||||
|
|
|
|||
|
|
@ -5,8 +5,6 @@ IN: ui.backend
|
|||
|
||||
SYMBOL: ui-backend
|
||||
|
||||
HOOK: do-events ui-backend ( -- )
|
||||
|
||||
HOOK: set-title ui-backend ( string world -- )
|
||||
|
||||
HOOK: set-fullscreen* ui-backend ( ? world -- )
|
||||
|
|
|
|||
|
|
@ -3,10 +3,11 @@
|
|||
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.nibs sequences system
|
||||
ui ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
|
||||
ui.cocoa.views core-foundation threads math.geometry.rect fry
|
||||
libc generalizations alien.c-types cocoa.views combinators ;
|
||||
cocoa.windows cocoa.classes cocoa.nibs sequences system ui
|
||||
ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
|
||||
ui.cocoa.views core-foundation core-foundation.run-loop threads
|
||||
math.geometry.rect fry libc generalizations alien.c-types
|
||||
cocoa.views combinators io.thread ;
|
||||
IN: ui.cocoa
|
||||
|
||||
TUPLE: handle ;
|
||||
|
|
@ -18,9 +19,6 @@ C: <offscreen-handle> offscreen-handle
|
|||
|
||||
SINGLETON: cocoa-ui-backend
|
||||
|
||||
M: cocoa-ui-backend do-events ( -- )
|
||||
[ NSApp '[ _ do-event ] loop ui-wait ] with-autorelease-pool ;
|
||||
|
||||
TUPLE: pasteboard handle ;
|
||||
|
||||
C: <pasteboard> pasteboard
|
||||
|
|
@ -134,8 +132,8 @@ CLASS: {
|
|||
{ +name+ "FactorApplicationDelegate" }
|
||||
}
|
||||
|
||||
{ "applicationDidFinishLaunching:" "void" { "id" "SEL" "id" }
|
||||
[ 3drop event-loop ]
|
||||
{ "applicationDidUpdate:" "void" { "id" "SEL" "id" }
|
||||
[ 3drop reset-run-loop ]
|
||||
} ;
|
||||
|
||||
: install-app-delegate ( -- )
|
||||
|
|
@ -153,6 +151,9 @@ M: cocoa-ui-backend ui
|
|||
init-clipboard
|
||||
cocoa-init-hook get call
|
||||
start-ui
|
||||
f io-thread-running? set-global
|
||||
init-thread-timer
|
||||
reset-run-loop
|
||||
NSApp -> run
|
||||
] ui-running
|
||||
] with-cocoa ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,19 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: ui.backend kernel namespaces sequences deques calendar
|
||||
threads ;
|
||||
IN: ui.event-loop
|
||||
|
||||
: event-loop? ( -- ? )
|
||||
{
|
||||
{ [ stop-after-last-window? get not ] [ t ] }
|
||||
{ [ graft-queue deque-empty? not ] [ t ] }
|
||||
{ [ windows get-global empty? not ] [ t ] }
|
||||
[ f ]
|
||||
} cond ;
|
||||
|
||||
HOOK: do-events ui-backend ( -- )
|
||||
|
||||
: event-loop ( quot -- ) [ event-loop? ] [ do-events ] [ ] while ;
|
||||
|
||||
: ui-wait ( -- ) 10 milliseconds sleep ;
|
||||
|
|
@ -143,9 +143,7 @@ ARTICLE: "ui-backend-init" "UI initialization and the event loop"
|
|||
}
|
||||
"The above word must call the following:"
|
||||
{ $subsection start-ui }
|
||||
"The " { $link ui } " word must not return until the event loop has stopped and the UI has been shut down."
|
||||
$nl
|
||||
"The event loop must not block, since otherwise other Factor threads and I/O will not run. Instead, it should poll for pending events, then call " { $link ui-wait } "." ;
|
||||
"The " { $link ui } " word must not return until the event loop has stopped and the UI has been shut down." ;
|
||||
|
||||
ARTICLE: "ui-backend-windows" "UI backend window management"
|
||||
"The high-level " { $link open-window } " word eventually calls a low-level word which you must implement:"
|
||||
|
|
|
|||
|
|
@ -12,16 +12,6 @@ SYMBOL: windows
|
|||
|
||||
SYMBOL: stop-after-last-window?
|
||||
|
||||
: event-loop? ( -- ? )
|
||||
{
|
||||
{ [ stop-after-last-window? get not ] [ t ] }
|
||||
{ [ graft-queue deque-empty? not ] [ t ] }
|
||||
{ [ windows get-global empty? not ] [ t ] }
|
||||
[ f ]
|
||||
} cond ;
|
||||
|
||||
: event-loop ( -- ) [ event-loop? ] [ do-events ] [ ] while ;
|
||||
|
||||
: window ( handle -- world ) windows get-global at ;
|
||||
|
||||
: window-focus ( handle -- gadget ) window world-focus ;
|
||||
|
|
@ -155,9 +145,6 @@ SYMBOL: ui-hook
|
|||
] assert-depth
|
||||
] [ ui-error ] recover ;
|
||||
|
||||
: ui-wait ( -- )
|
||||
10 milliseconds sleep ;
|
||||
|
||||
SYMBOL: ui-thread
|
||||
|
||||
: ui-running ( quot -- )
|
||||
|
|
|
|||
|
|
@ -3,14 +3,14 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.strings arrays assocs ui
|
||||
ui.gadgets ui.backend ui.clipboards ui.gadgets.worlds
|
||||
ui.gestures io kernel math math.vectors namespaces make
|
||||
sequences strings vectors words windows.kernel32 windows.gdi32
|
||||
windows.user32 windows.opengl32 windows.messages windows.types
|
||||
windows.nt windows threads libc combinators fry
|
||||
ui.gestures ui.event-loop io kernel math math.vectors namespaces
|
||||
make sequences strings vectors words windows.kernel32
|
||||
windows.gdi32 windows.user32 windows.opengl32 windows.messages
|
||||
windows.types windows.nt windows threads libc combinators fry
|
||||
combinators.short-circuit continuations command-line shuffle
|
||||
opengl ui.render ascii math.bitwise locals symbols accessors
|
||||
math.geometry.rect math.order ascii calendar
|
||||
io.encodings.utf16n ;
|
||||
math.geometry.rect math.order ascii calendar io.encodings.utf16n
|
||||
;
|
||||
IN: ui.windows
|
||||
|
||||
SINGLETON: windows-ui-backend
|
||||
|
|
|
|||
|
|
@ -2,9 +2,9 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.c-types arrays ui ui.gadgets
|
||||
ui.gestures ui.backend ui.clipboards ui.gadgets.worlds ui.render
|
||||
assocs kernel math namespaces opengl sequences strings x11.xlib
|
||||
x11.events x11.xim x11.glx x11.clipboard x11.constants
|
||||
x11.windows io.encodings.string io.encodings.ascii
|
||||
ui.event-loop assocs kernel math namespaces opengl sequences
|
||||
strings x11.xlib x11.events x11.xim x11.glx x11.clipboard
|
||||
x11.constants x11.windows io.encodings.string io.encodings.ascii
|
||||
io.encodings.utf8 combinators command-line qualified
|
||||
math.vectors classes.tuple opengl.gl threads math.geometry.rect
|
||||
environment ascii ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs kernel math namespaces sequences system
|
||||
kernel.private byte-arrays arrays ;
|
||||
kernel.private byte-arrays arrays init ;
|
||||
IN: alien
|
||||
|
||||
! Some predicate classes used by the compiler for optimization
|
||||
|
|
@ -72,3 +72,9 @@ ERROR: alien-invoke-error library symbol ;
|
|||
|
||||
: alien-invoke ( ... return library function parameters -- ... )
|
||||
2over alien-invoke-error ;
|
||||
|
||||
! Callbacks are registered in a global hashtable. If you clear
|
||||
! this hashtable, they will all be blown away by code GC, beware.
|
||||
SYMBOL: callbacks
|
||||
|
||||
[ H{ } clone callbacks set-global ] "alien" add-init-hook
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: init kernel system namespaces io io.encodings
|
||||
io.encodings.utf8 init assocs splitting ;
|
||||
io.encodings.utf8 init assocs splitting alien ;
|
||||
IN: io.backend
|
||||
|
||||
SYMBOL: io-backend
|
||||
|
|
@ -32,5 +32,7 @@ M: object normalize-directory normalize-path ;
|
|||
io-backend set-global init-io init-stdio
|
||||
"io.files" init-hooks get at call ;
|
||||
|
||||
! Note that we have 'alien' in our using list so that the alien
|
||||
! init hook runs before this one.
|
||||
[ init-io embedded? [ init-stdio ] unless ]
|
||||
"io.backend" add-init-hook
|
||||
|
|
|
|||
|
|
@ -151,7 +151,8 @@ M: source-file fuel-pprint path>> fuel-pprint ;
|
|||
: fuel-end-eval ( -- ) [ ] (fuel-end-eval) ; inline
|
||||
|
||||
: fuel-get-edit-location ( defspec -- )
|
||||
where [ first2 [ (normalize-path) ] dip 2array fuel-eval-set-result ] when* ;
|
||||
where [ first2 [ (normalize-path) ] dip 2array fuel-eval-set-result ]
|
||||
when* ;
|
||||
|
||||
: fuel-run-file ( path -- ) run-file ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
USING: alien.syntax alien.c-types core-foundation system
|
||||
combinators kernel sequences debugger io accessors ;
|
||||
USING: alien.syntax alien.c-types core-foundation
|
||||
core-foundation.bundles system combinators kernel sequences
|
||||
debugger io accessors ;
|
||||
IN: iokit
|
||||
|
||||
<<
|
||||
|
|
|
|||
|
|
@ -50,7 +50,7 @@ Quick key reference
|
|||
(Chords ending in a single letter <x> accept also C-<x> (e.g. C-cC-z is
|
||||
the same as C-cz)).
|
||||
|
||||
* In factor files:
|
||||
* In factor source files:
|
||||
|
||||
- C-cz : switch to listener
|
||||
- C-co : cycle between code, tests and docs factor files
|
||||
|
|
@ -70,6 +70,13 @@ the same as C-cz)).
|
|||
|
||||
- g : go to error
|
||||
- <digit> : invoke nth restart
|
||||
- w/e/l : invoke :warnings, :errors, :linkage
|
||||
- q : bury buffer
|
||||
|
||||
* In the Help browser:
|
||||
|
||||
- RET : help for word at point
|
||||
- f/b : next/previous page
|
||||
- SPC/S-SPC : scroll up/down
|
||||
- q: bury buffer
|
||||
|
||||
|
|
|
|||
|
|
@ -59,5 +59,7 @@
|
|||
" ")
|
||||
len))
|
||||
|
||||
(defsubst empty-string-p (str) (equal str ""))
|
||||
|
||||
(provide 'fuel-base)
|
||||
;;; fuel-base.el ends here
|
||||
|
|
|
|||
|
|
@ -0,0 +1,186 @@
|
|||
;;; fuel-connection.el -- asynchronous comms with 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, fuel, factor
|
||||
;; Start date: Thu Dec 11, 2008 03:10
|
||||
|
||||
;;; Comentary:
|
||||
|
||||
;; Handling communications via a comint buffer running a factor
|
||||
;; listener.
|
||||
|
||||
;;; Code:
|
||||
|
||||
|
||||
;;; Default connection:
|
||||
|
||||
(make-variable-buffer-local
|
||||
(defvar fuel-con--connection nil))
|
||||
|
||||
(defun fuel-con--get-connection (buffer/proc)
|
||||
(if (processp buffer/proc)
|
||||
(fuel-con--get-connection (process-buffer buffer/proc))
|
||||
(with-current-buffer buffer/proc
|
||||
(or fuel-con--connection
|
||||
(setq fuel-con--connection
|
||||
(fuel-con--setup-connection buffer/proc))))))
|
||||
|
||||
|
||||
;;; Request and connection datatypes:
|
||||
|
||||
(defun fuel-con--connection-queue-request (c r)
|
||||
(let ((reqs (assoc :requests c)))
|
||||
(setcdr reqs (append (cdr reqs) (list r)))))
|
||||
|
||||
(defun fuel-con--make-request (str cont &optional sender-buffer)
|
||||
(list :fuel-connection-request
|
||||
(cons :id (random))
|
||||
(cons :string str)
|
||||
(cons :continuation cont)
|
||||
(cons :buffer (or sender-buffer (current-buffer)))))
|
||||
|
||||
(defsubst fuel-con--request-p (req)
|
||||
(and (listp req) (eq (car req) :fuel-connection-request)))
|
||||
|
||||
(defsubst fuel-con--request-id (req)
|
||||
(cdr (assoc :id req)))
|
||||
|
||||
(defsubst fuel-con--request-string (req)
|
||||
(cdr (assoc :string req)))
|
||||
|
||||
(defsubst fuel-con--request-continuation (req)
|
||||
(cdr (assoc :continuation req)))
|
||||
|
||||
(defsubst fuel-con--request-buffer (req)
|
||||
(cdr (assoc :buffer req)))
|
||||
|
||||
(defsubst fuel-con--request-deactivate (req)
|
||||
(setcdr (assoc :continuation req) nil))
|
||||
|
||||
(defsubst fuel-con--request-deactivated-p (req)
|
||||
(null (cdr (assoc :continuation req))))
|
||||
|
||||
(defsubst fuel-con--make-connection (buffer)
|
||||
(list :fuel-connection
|
||||
(list :requests)
|
||||
(list :current)
|
||||
(cons :completed (make-hash-table :weakness 'value))
|
||||
(cons :buffer buffer)))
|
||||
|
||||
(defsubst fuel-con--connection-p (c)
|
||||
(and (listp c) (eq (car c) :fuel-connection)))
|
||||
|
||||
(defsubst fuel-con--connection-requests (c)
|
||||
(cdr (assoc :requests c)))
|
||||
|
||||
(defsubst fuel-con--connection-current-request (c)
|
||||
(cdr (assoc :current c)))
|
||||
|
||||
(defun fuel-con--connection-clean-current-request (c)
|
||||
(let* ((cell (assoc :current c))
|
||||
(req (cdr cell)))
|
||||
(when req
|
||||
(puthash (fuel-con--request-id req) req (cdr (assoc :completed c)))
|
||||
(setcdr cell nil))))
|
||||
|
||||
(defsubst fuel-con--connection-completed-p (c id)
|
||||
(gethash id (cdr (assoc :completed c))))
|
||||
|
||||
(defsubst fuel-con--connection-buffer (c)
|
||||
(cdr (assoc :buffer c)))
|
||||
|
||||
(defun fuel-con--connection-pop-request (c)
|
||||
(let ((reqs (assoc :requests c))
|
||||
(current (assoc :current c)))
|
||||
(setcdr current (prog1 (cadr reqs) (setcdr reqs (cddr reqs))))
|
||||
(if (and current (fuel-con--request-deactivated-p current))
|
||||
(fuel-con--connection-pop-request c)
|
||||
current)))
|
||||
|
||||
|
||||
;;; Connection setup:
|
||||
|
||||
(defun fuel-con--setup-connection (buffer)
|
||||
(set-buffer buffer)
|
||||
(let ((conn (fuel-con--make-connection buffer)))
|
||||
(fuel-con--setup-comint)
|
||||
(setq fuel-con--connection conn)))
|
||||
|
||||
(defun fuel-con--setup-comint ()
|
||||
(add-hook 'comint-redirect-filter-functions
|
||||
'fuel-con--comint-redirect-filter t t))
|
||||
|
||||
|
||||
;;; Requests handling:
|
||||
|
||||
(defun fuel-con--process-next (con)
|
||||
(when (not (fuel-con--connection-current-request con))
|
||||
(let* ((buffer (fuel-con--connection-buffer con))
|
||||
(req (fuel-con--connection-pop-request con))
|
||||
(str (and req (fuel-con--request-string req))))
|
||||
(when (and buffer req str)
|
||||
(set-buffer buffer)
|
||||
(comint-redirect-send-command str
|
||||
(get-buffer-create "*factor messages*")
|
||||
nil
|
||||
t)))))
|
||||
|
||||
(defun fuel-con--comint-redirect-filter (str)
|
||||
(if (not fuel-con--connection)
|
||||
(format "\nERROR: No connection in buffer (%s)\n" str)
|
||||
(let ((req (fuel-con--connection-current-request fuel-con--connection)))
|
||||
(if (not req) (format "\nERROR: No current request (%s)\n" str)
|
||||
(let ((cont (fuel-con--request-continuation req))
|
||||
(id (fuel-con--request-id req))
|
||||
(rstr (fuel-con--request-string req))
|
||||
(buffer (fuel-con--request-buffer req)))
|
||||
(prog1
|
||||
(if (not cont)
|
||||
(format "\nWARNING: Droping result for request %s:%S (%s)\n"
|
||||
id rstr str)
|
||||
(condition-case cerr
|
||||
(with-current-buffer (or buffer (current-buffer))
|
||||
(funcall cont str)
|
||||
(format "\nINFO: %s:%S processed\nINFO: %s\n" id rstr str))
|
||||
(error (format "\nERROR: continuation failed %s:%S \nERROR: %s\n"
|
||||
id rstr cerr))))
|
||||
(fuel-con--connection-clean-current-request fuel-con--connection)))))))
|
||||
|
||||
|
||||
;;; Message sending interface:
|
||||
|
||||
(defun fuel-con--send-string (buffer/proc str cont &optional sender-buffer)
|
||||
(save-current-buffer
|
||||
(let ((con (fuel-con--get-connection buffer/proc)))
|
||||
(unless con
|
||||
(error "FUEL: couldn't find connection"))
|
||||
(let ((req (fuel-con--make-request str cont sender-buffer)))
|
||||
(fuel-con--connection-queue-request con req)
|
||||
(fuel-con--process-next con)
|
||||
req))))
|
||||
|
||||
(defvar fuel-connection-timeout 30000
|
||||
"Time limit, in msecs, blocking on synchronous evaluation requests")
|
||||
|
||||
(defun fuel-con--send-string/wait (buffer/proc str cont &optional timeout sbuf)
|
||||
(save-current-buffer
|
||||
(let* ((con (fuel-con--get-connection buffer/proc))
|
||||
(req (fuel-con--send-string buffer/proc str cont sbuf))
|
||||
(id (and req (fuel-con--request-id req)))
|
||||
(time (or timeout fuel-connection-timeout))
|
||||
(step 2))
|
||||
(when id
|
||||
(while (and (> time 0)
|
||||
(not (fuel-con--connection-completed-p con id)))
|
||||
(sleep-for 0 step)
|
||||
(setq time (- time step)))
|
||||
(or (> time 0)
|
||||
(fuel-con--request-deactivate req)
|
||||
nil)))))
|
||||
|
||||
|
||||
(provide 'fuel-connection)
|
||||
;;; fuel-connection.el ends here
|
||||
|
|
@ -214,7 +214,7 @@
|
|||
(buffer (if file (find-file-noselect file) (current-buffer))))
|
||||
(with-current-buffer buffer
|
||||
(fuel-debug--display-retort
|
||||
(fuel-eval--eval-string/context (format ":%s" n))
|
||||
(fuel-eval--send/wait (fuel-eval--cmd/string (format ":%s" n)))
|
||||
(format "Restart %s (%s) successful" n (nth (1- n) rs))))))))
|
||||
|
||||
(defun fuel-debug-show--compiler-info (info)
|
||||
|
|
@ -224,7 +224,8 @@
|
|||
(error "%s information not available" info))
|
||||
(message "Retrieving %s info ..." info)
|
||||
(unless (fuel-debug--display-retort
|
||||
(fuel-eval--eval-string info) "" (fuel-debug--buffer-file))
|
||||
(fuel-eval--send/wait (fuel-eval--cmd/string info))
|
||||
"" (fuel-debug--buffer-file))
|
||||
(error "Sorry, no %s info available" info))))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
;;; fuel-eval.el --- utilities for communication with fuel-listener
|
||||
;;; fuel-eval.el --- evaluating Factor expressions
|
||||
|
||||
;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
|
||||
;; See http://factorcode.org/license.txt for BSD license.
|
||||
|
|
@ -9,46 +9,16 @@
|
|||
|
||||
;;; Commentary:
|
||||
|
||||
;; Protocols for handling communications via a comint buffer running a
|
||||
;; factor listener.
|
||||
;; Protocols for sending evaluations to the Factor listener.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'fuel-base)
|
||||
(require 'fuel-syntax)
|
||||
(require 'fuel-connection)
|
||||
|
||||
|
||||
;;; 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 256)))
|
||||
(newline)
|
||||
(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
|
||||
;;; Retort and retort-error datatypes:
|
||||
|
||||
(defsubst fuel-eval--retort-make (err result &optional output)
|
||||
(list err result output))
|
||||
|
|
@ -60,57 +30,14 @@
|
|||
(defsubst fuel-eval--retort-p (ret) (listp ret))
|
||||
|
||||
(defsubst fuel-eval--make-parse-error-retort (str)
|
||||
(fuel-eval--retort-make 'parse-retort-error nil str))
|
||||
(fuel-eval--retort-make (cons 'fuel-parse-retort-error str) nil))
|
||||
|
||||
(defun fuel-eval--parse-retort (buffer)
|
||||
(defun fuel-eval--parse-retort (str)
|
||||
(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 &optional no-restart)
|
||||
(let ((str (format "fuel-eval-%s %s fuel-eval"
|
||||
(if no-restart "non-restartable" "restartable")
|
||||
(fuel-eval--factor-array strs))))
|
||||
(fuel-eval--send/retort str)))
|
||||
|
||||
(defsubst fuel-eval--eval-string (str &optional no-restart)
|
||||
(fuel-eval--eval-strings (list str) no-restart))
|
||||
|
||||
(defun fuel-eval--eval-strings/context (strs &optional no-restart)
|
||||
(let ((usings (fuel-syntax--usings-update)))
|
||||
(fuel-eval--send/retort
|
||||
(format "fuel-eval-%s %s %S %s fuel-eval-in-context"
|
||||
(if no-restart "non-restartable" "restartable")
|
||||
(fuel-eval--factor-array strs)
|
||||
(or fuel-syntax--current-vocab "f")
|
||||
(if usings (fuel-eval--factor-array usings) "f")))))
|
||||
|
||||
(defsubst fuel-eval--eval-string/context (str &optional no-restart)
|
||||
(fuel-eval--eval-strings/context (list str) no-restart))
|
||||
|
||||
(defun fuel-eval--eval-region/context (begin end &optional no-restart)
|
||||
(let ((lines (split-string (buffer-substring-no-properties begin end)
|
||||
"[\f\n\r\v]+" t)))
|
||||
(when (> (length lines) 0)
|
||||
(fuel-eval--eval-strings/context lines no-restart))))
|
||||
|
||||
|
||||
;;; Error parsing
|
||||
(let ((ret (car (read-from-string str))))
|
||||
(if (fuel-eval--retort-p ret) ret (error)))
|
||||
(error (fuel-eval--make-parse-error-retort str)))))
|
||||
|
||||
(defsubst fuel-eval--error-name (err) (car err))
|
||||
|
||||
|
|
@ -137,6 +64,69 @@
|
|||
(defsubst fuel-eval--error-line-text (err)
|
||||
(nth 3 (fuel-eval--error-lexer-p err)))
|
||||
|
||||
|
||||
;;; 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)
|
||||
|
||||
(defvar fuel-eval--sync-retort nil)
|
||||
|
||||
(defun fuel-eval--send/wait (str &optional timeout buffer)
|
||||
(setq fuel-eval--sync-retort nil)
|
||||
(fuel-con--send-string/wait (or fuel-eval--proc (fuel-eval--default-proc))
|
||||
str
|
||||
'(lambda (s)
|
||||
(setq fuel-eval--sync-retort
|
||||
(fuel-eval--parse-retort s)))
|
||||
timeout
|
||||
buffer)
|
||||
fuel-eval--sync-retort)
|
||||
|
||||
(defun fuel-eval--send (str cont &optional buffer)
|
||||
(fuel-con--send-string (or fuel-eval--proc (fuel-eval--default-proc))
|
||||
str
|
||||
`(lambda (s) (,cont (fuel-eval--parse-retort s)))
|
||||
buffer))
|
||||
|
||||
|
||||
;;; Evaluation protocol
|
||||
|
||||
(defsubst fuel-eval--factor-array (strs)
|
||||
(format "V{ %S }" (mapconcat 'identity strs " ")))
|
||||
|
||||
(defun fuel-eval--cmd/lines (strs &optional no-rs in usings)
|
||||
(unless (and in usings) (fuel-syntax--usings-update))
|
||||
(let* ((in (cond ((not in) (or fuel-syntax--current-vocab "f"))
|
||||
((eq in t) "fuel-scratchpad")
|
||||
(in in)))
|
||||
(usings (cond ((not usings) fuel-syntax--usings)
|
||||
((eq usings t) nil)
|
||||
(usings usings))))
|
||||
(format "fuel-eval-%srestartable %s %S %s fuel-eval-in-context"
|
||||
(if no-rs "non-" "")
|
||||
(fuel-eval--factor-array strs)
|
||||
in
|
||||
(fuel-eval--factor-array usings))))
|
||||
|
||||
(defsubst fuel-eval--cmd/string (str &optional no-rs in usings)
|
||||
(fuel-eval--cmd/lines (list str) no-rs in usings))
|
||||
|
||||
(defun fuel-eval--cmd/region (begin end &optional no-rs in usings)
|
||||
(let ((lines (split-string (buffer-substring-no-properties begin end)
|
||||
"[\f\n\r\v]+" t)))
|
||||
(when (> (length lines) 0)
|
||||
(fuel-eval--cmd/lines lines no-rs in usings))))
|
||||
|
||||
|
||||
|
||||
(provide 'fuel-eval)
|
||||
;;; fuel-eval.el ends here
|
||||
|
|
|
|||
|
|
@ -57,7 +57,7 @@
|
|||
(,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--parent-type-regex 1 'factor-font-lock-type-name)
|
||||
(,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)
|
||||
|
|
|
|||
|
|
@ -45,6 +45,11 @@
|
|||
:type 'hook
|
||||
:group 'fuel-help)
|
||||
|
||||
(defcustom fuel-help-history-cache-size 50
|
||||
"Maximum number of pages to keep in the help browser cache."
|
||||
:type 'integer
|
||||
:group 'fuel-help)
|
||||
|
||||
(defface fuel-help-font-lock-headlines '((t (:bold t :weight bold)))
|
||||
"Face for headlines in help buffers."
|
||||
:group 'fuel-help
|
||||
|
|
@ -70,10 +75,10 @@
|
|||
(let ((word (or word (fuel-syntax-symbol-at-point)))
|
||||
(fuel-eval--log t))
|
||||
(when word
|
||||
(let ((ret (fuel-eval--eval-string/context
|
||||
(format "\\ %s synopsis fuel-eval-set-result" word)
|
||||
t)))
|
||||
(when (not (fuel-eval--retort-error ret))
|
||||
(let* ((str (format "\\ %s synopsis fuel-eval-set-result" word))
|
||||
(cmd (fuel-eval--cmd/string str t t))
|
||||
(ret (fuel-eval--send/wait cmd 20)))
|
||||
(when (and ret (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)))))))
|
||||
|
|
@ -101,92 +106,83 @@ displayed in the minibuffer."
|
|||
(message "Fuel Autodoc %s" (if fuel-autodoc-mode "enabled" "disabled")))
|
||||
|
||||
|
||||
;;;; Factor help mode:
|
||||
;;; Help browser history:
|
||||
|
||||
(defvar fuel-help-mode-map (make-sparse-keymap)
|
||||
"Keymap for Factor help mode.")
|
||||
(defvar fuel-help--history
|
||||
(list nil
|
||||
(make-ring fuel-help-history-cache-size)
|
||||
(make-ring fuel-help-history-cache-size)))
|
||||
|
||||
(define-key fuel-help-mode-map [(return)] 'fuel-help)
|
||||
(defvar fuel-help--history-idx 0)
|
||||
|
||||
(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))
|
||||
(defun fuel-help--history-push (term)
|
||||
(when (car fuel-help--history)
|
||||
(ring-insert (nth 1 fuel-help--history) (car fuel-help--history)))
|
||||
(setcar fuel-help--history term))
|
||||
|
||||
(defconst fuel-help--headlines-regexp (format "^%s" fuel-help--headlines))
|
||||
(defun fuel-help--history-next ()
|
||||
(when (not (ring-empty-p (nth 2 fuel-help--history)))
|
||||
(when (car fuel-help--history)
|
||||
(ring-insert (nth 1 fuel-help--history) (car fuel-help--history)))
|
||||
(setcar fuel-help--history (ring-remove (nth 2 fuel-help--history) 0))))
|
||||
|
||||
(defconst fuel-help--font-lock-keywords
|
||||
`(,@fuel-font-lock--font-lock-keywords
|
||||
(,fuel-help--headlines-regexp . 'fuel-help-font-lock-headlines)))
|
||||
(defun fuel-help--history-previous ()
|
||||
(when (not (ring-empty-p (nth 1 fuel-help--history)))
|
||||
(when (car fuel-help--history)
|
||||
(ring-insert (nth 2 fuel-help--history) (car fuel-help--history)))
|
||||
(setcar fuel-help--history (ring-remove (nth 1 fuel-help--history) 0))))
|
||||
|
||||
(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))
|
||||
|
||||
;;; Fuel help buffer and internals:
|
||||
|
||||
(defun fuel-help--help-buffer ()
|
||||
(with-current-buffer (get-buffer-create "*fuel-help*")
|
||||
(fuel-help-mode)
|
||||
(current-buffer)))
|
||||
|
||||
(defvar fuel-help--history nil)
|
||||
(defvar fuel-help--prompt-history nil)
|
||||
|
||||
(defun fuel-help--show-help (&optional see)
|
||||
(let* ((def (fuel-syntax-symbol-at-point))
|
||||
(defun fuel-help--show-help (&optional see word)
|
||||
(let* ((def (or word (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 t))
|
||||
(out (fuel-eval--retort-output ret)))
|
||||
(def (if ask (read-string prompt nil 'fuel-help--prompt-history def)
|
||||
def))
|
||||
(cmd (format "\\ %s %s" def (if see "see" "help"))))
|
||||
(message "Looking up '%s' ..." def)
|
||||
(fuel-eval--send (fuel-eval--cmd/string cmd t t)
|
||||
`(lambda (r) (fuel-help--show-help-cont ,def r)))))
|
||||
|
||||
(defun fuel-help--show-help-cont (def ret)
|
||||
(let ((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))))))
|
||||
(fuel-help--insert-contents def out))))
|
||||
|
||||
(defun fuel-help--insert-contents (def str &optional nopush)
|
||||
(let ((hb (fuel-help--help-buffer))
|
||||
(inhibit-read-only t)
|
||||
(font-lock-verbose nil))
|
||||
(set-buffer hb)
|
||||
(erase-buffer)
|
||||
(insert str)
|
||||
(goto-char (point-min))
|
||||
(when (re-search-forward (format "^%s" def) nil t)
|
||||
(beginning-of-line)
|
||||
(kill-region (point-min) (point))
|
||||
(next-line)
|
||||
(open-line 1))
|
||||
(set-buffer-modified-p nil)
|
||||
(unless nopush (fuel-help--history-push (cons def str)))
|
||||
(pop-to-buffer hb)
|
||||
(goto-char (point-min))
|
||||
(message "%s" def)))
|
||||
|
||||
|
||||
;;; Interface: see/help commands
|
||||
;;; Interactive help commands:
|
||||
|
||||
(defun fuel-help-short (&optional arg)
|
||||
"See a help summary of symbol at point.
|
||||
|
|
@ -204,6 +200,79 @@ buffer."
|
|||
(interactive)
|
||||
(fuel-help--show-help))
|
||||
|
||||
(defun fuel-help-next ()
|
||||
"Go to next page in help browser."
|
||||
(interactive)
|
||||
(let ((item (fuel-help--history-next))
|
||||
(fuel-help-always-ask nil))
|
||||
(unless item
|
||||
(error "No next page"))
|
||||
(fuel-help--insert-contents (car item) (cdr item) t)))
|
||||
|
||||
(defun fuel-help-previous ()
|
||||
"Go to next page in help browser."
|
||||
(interactive)
|
||||
(let ((item (fuel-help--history-previous))
|
||||
(fuel-help-always-ask nil))
|
||||
(unless item
|
||||
(error "No previous page"))
|
||||
(fuel-help--insert-contents (car item) (cdr item) t)))
|
||||
|
||||
|
||||
;;;; Factor help mode:
|
||||
|
||||
(defvar fuel-help-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map "\C-m" 'fuel-help)
|
||||
(define-key map "q" 'bury-buffer)
|
||||
(define-key map "b" 'fuel-help-previous)
|
||||
(define-key map "f" 'fuel-help-next)
|
||||
(define-key map (kbd "SPC") 'scroll-up)
|
||||
(define-key map (kbd "S-SPC") 'scroll-down)
|
||||
map))
|
||||
|
||||
(defconst fuel-help--headlines
|
||||
(regexp-opt '("Class description"
|
||||
"Definition"
|
||||
"Errors"
|
||||
"Examples"
|
||||
"Generic word contract"
|
||||
"Inputs and outputs"
|
||||
"Methods"
|
||||
"Notes"
|
||||
"Parent topics:"
|
||||
"See also"
|
||||
"Syntax"
|
||||
"Variable description"
|
||||
"Variable value"
|
||||
"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 browsing 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)
|
||||
|
||||
(setq fuel-autodoc-mode-string "")
|
||||
(fuel-autodoc-mode)
|
||||
|
||||
(run-mode-hooks 'fuel-help-mode-hook)
|
||||
(toggle-read-only 1))
|
||||
|
||||
|
||||
(provide 'fuel-help)
|
||||
;;; fuel-help.el ends here
|
||||
|
|
|
|||
|
|
@ -66,7 +66,7 @@ buffer."
|
|||
(comint-exec fuel-listener-buffer "factor"
|
||||
factor nil `("-run=fuel" ,(format "-i=%s" image)))
|
||||
(fuel-listener--wait-for-prompt 20)
|
||||
(fuel-eval--send-string "USE: fuel")
|
||||
(fuel-eval--send/wait "USE: fuel")
|
||||
(message "FUEL listener up and running!"))))
|
||||
|
||||
(defun fuel-listener--process (&optional start)
|
||||
|
|
@ -83,18 +83,18 @@ buffer."
|
|||
;;; Prompt chasing
|
||||
|
||||
(defun fuel-listener--wait-for-prompt (&optional timeout)
|
||||
(let ((proc (get-buffer-process fuel-listener-buffer))
|
||||
(seen))
|
||||
(with-current-buffer fuel-listener-buffer
|
||||
(while (progn (goto-char comint-last-input-end)
|
||||
(not (or seen
|
||||
(setq seen
|
||||
(re-search-forward comint-prompt-regexp nil t))
|
||||
(not (accept-process-output proc timeout))))))
|
||||
(goto-char (point-max)))
|
||||
(unless seen
|
||||
(let ((proc (get-buffer-process fuel-listener-buffer)))
|
||||
(with-current-buffer fuel-listener-buffer
|
||||
(goto-char (or comint-last-input-end (point-min)))
|
||||
(let ((seen (re-search-forward comint-prompt-regexp nil t)))
|
||||
(while (and (not seen)
|
||||
(accept-process-output proc (or timeout 10) nil t))
|
||||
(sleep-for 0 1)
|
||||
(goto-char comint-last-input-end)
|
||||
(setq seen (re-search-forward comint-prompt-regexp nil t)))
|
||||
(pop-to-buffer fuel-listener-buffer)
|
||||
(error "No prompt found!"))))
|
||||
(goto-char (point-max))
|
||||
(unless seen (error "No prompt found!"))))))
|
||||
|
||||
|
||||
;;; Interface: starting fuel listener
|
||||
|
|
@ -124,6 +124,8 @@ buffer."
|
|||
(set (make-local-variable 'comint-prompt-read-only) t)
|
||||
(setq fuel-listener--compilation-begin nil))
|
||||
|
||||
(define-key fuel-listener-mode-map "\C-cz" 'run-factor)
|
||||
(define-key fuel-listener-mode-map "\C-c\C-z" 'run-factor)
|
||||
(define-key fuel-listener-mode-map "\C-ch" 'fuel-help)
|
||||
(define-key fuel-listener-mode-map "\M-." 'fuel-edit-word-at-point)
|
||||
(define-key fuel-listener-mode-map "\C-ck" 'fuel-run-file)
|
||||
|
|
|
|||
|
|
@ -45,16 +45,20 @@ With prefix argument, ask for the file to run."
|
|||
(let* ((file (or (and arg (read-file-name "File: " nil (buffer-file-name) t))
|
||||
(buffer-file-name)))
|
||||
(file (expand-file-name file))
|
||||
(buffer (find-file-noselect file))
|
||||
(cmd (format "%S fuel-run-file" file)))
|
||||
(buffer (find-file-noselect file)))
|
||||
(when buffer
|
||||
(with-current-buffer buffer
|
||||
(message "Compiling %s ..." file)
|
||||
(let ((r (fuel-debug--display-retort (fuel-eval--eval-string/context cmd)
|
||||
(format "%s successfully compiled" file)
|
||||
nil
|
||||
file)))
|
||||
(if r (message "Compiling %s ... OK!" file) (message "")))))))
|
||||
(fuel-eval--send (fuel-eval--cmd/string (format "%S fuel-run-file" file))
|
||||
`(lambda (r) (fuel--run-file-cont r ,file)))))))
|
||||
|
||||
(defun fuel--run-file-cont (ret file)
|
||||
(if (fuel-debug--display-retort ret
|
||||
(format "%s successfully compiled" file)
|
||||
nil
|
||||
file)
|
||||
(message "Compiling %s ... OK!" file)
|
||||
(message "")))
|
||||
|
||||
(defun fuel-eval-region (begin end &optional arg)
|
||||
"Sends region to Fuel's listener for evaluation.
|
||||
|
|
@ -62,7 +66,7 @@ Unless called with a prefix, switchs to the compilation results
|
|||
buffer in case of errors."
|
||||
(interactive "r\nP")
|
||||
(fuel-debug--display-retort
|
||||
(fuel-eval--eval-region/context begin end)
|
||||
(fuel-eval--send/wait (fuel-eval--cmd/region begin end) 10000)
|
||||
(format "%s%s"
|
||||
(if fuel-syntax--current-vocab
|
||||
(format "IN: %s " fuel-syntax--current-vocab)
|
||||
|
|
@ -105,8 +109,9 @@ With prefix, asks for the word to edit."
|
|||
(if word (format " (%s)" word) ""))
|
||||
word)
|
||||
word)))
|
||||
(let* ((ret (fuel-eval--eval-string/context
|
||||
(let* ((str (fuel-eval--cmd/string
|
||||
(format "\\ %s fuel-get-edit-location" word)))
|
||||
(ret (fuel-eval--send/wait str))
|
||||
(err (fuel-eval--retort-error ret))
|
||||
(loc (fuel-eval--retort-result ret)))
|
||||
(when (or err (not loc) (not (listp loc)) (not (stringp (car loc))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue