Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2008-12-13 00:23:31 -06:00
commit 919a4393f5
33 changed files with 657 additions and 291 deletions

View File

@ -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

View File

@ -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

View File

@ -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 = ;

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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 -- )

View File

@ -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

View File

@ -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 }
}

View File

@ -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

View File

@ -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 }
}

View File

@ -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

View File

@ -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 -- )

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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:"

View File

@ -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 -- )

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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
<<

View File

@ -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

View File

@ -59,5 +59,7 @@
" ")
len))
(defsubst empty-string-p (str) (equal str ""))
(provide 'fuel-base)
;;; fuel-base.el ends here

View File

@ -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

View File

@ -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))))

View File

@ -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

View File

@ -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)

View File

@ -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

View File

@ -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)

View 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))))