From eb86d88dd4f2f9fd6ad9dd76d2a61084fc99d75f Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Tue, 9 Dec 2008 16:40:32 -0800 Subject: [PATCH 001/838] Fix typo in math.binpack-docs. --- extra/math/binpack/binpack-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/math/binpack/binpack-docs.factor b/extra/math/binpack/binpack-docs.factor index 36a29c7aa1..d995cab59d 100644 --- a/extra/math/binpack/binpack-docs.factor +++ b/extra/math/binpack/binpack-docs.factor @@ -15,5 +15,5 @@ HELP: binpack* HELP: binpack! { $values { "items" sequence } { "quot" quotation } { "n" "number of bins" } { "bins" "packed bins" } } -{ $description "Packs a sequence of items into the specified number of bins, using the quotatino to determine the weight." } ; +{ $description "Packs a sequence of items into the specified number of bins, using the quotation to determine the weight." } ; From 3dc417ae6479305091e15380f99b4251cfa2462b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 11 Dec 2008 18:52:22 -0600 Subject: [PATCH 002/838] bool -> ? --- basis/db/sqlite/lib/lib.factor | 2 +- basis/smtp/smtp.factor | 2 +- basis/ui/windows/windows.factor | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/db/sqlite/lib/lib.factor b/basis/db/sqlite/lib/lib.factor index 1ec18260cd..bcd38b172d 100644 --- a/basis/db/sqlite/lib/lib.factor +++ b/basis/db/sqlite/lib/lib.factor @@ -166,7 +166,7 @@ ERROR: sqlite-sql-error < sql-error n string ; : sqlite-row ( handle -- seq ) dup sqlite-#columns [ sqlite-column ] with map ; -: sqlite-step-has-more-rows? ( prepared -- bool ) +: sqlite-step-has-more-rows? ( prepared -- ? ) { { SQLITE_ROW [ t ] } { SQLITE_DONE [ f ] } diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor index f689ad0858..0f16863a79 100644 --- a/basis/smtp/smtp.factor +++ b/basis/smtp/smtp.factor @@ -102,7 +102,7 @@ M: message-contains-dot summary ( obj -- string ) LOG: smtp-response DEBUG -: multiline? ( response -- boolean ) +: multiline? ( response -- ? ) 3 swap ?nth CHAR: - = ; : (receive-response) ( -- ) diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor index 10539df8e7..626deb12a4 100755 --- a/basis/ui/windows/windows.factor +++ b/basis/ui/windows/windows.factor @@ -170,10 +170,10 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ; { 27 "ESC" } } ; -: exclude-key-wm-keydown? ( n -- bool ) +: exclude-key-wm-keydown? ( n -- ? ) exclude-keys-wm-keydown key? ; -: exclude-key-wm-char? ( n -- bool ) +: exclude-key-wm-char? ( n -- ? ) exclude-keys-wm-char key? ; : keystroke>gesture ( n -- mods sym ) From afe942130edef0def7e781587aa7fd7be85a403e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 11 Dec 2008 23:11:04 -0600 Subject: [PATCH 003/838] Add deep-member? and deep-subseq? to sequences.deep. --- basis/sequences/deep/authors.txt | 1 + basis/sequences/deep/deep-tests.factor | 15 +++++++++++++++ basis/sequences/deep/deep.factor | 14 ++++++++++++-- 3 files changed, 28 insertions(+), 2 deletions(-) diff --git a/basis/sequences/deep/authors.txt b/basis/sequences/deep/authors.txt index f990dd0ed2..a07c427c98 100644 --- a/basis/sequences/deep/authors.txt +++ b/basis/sequences/deep/authors.txt @@ -1 +1,2 @@ Daniel Ehrenberg +Doug Coleman diff --git a/basis/sequences/deep/deep-tests.factor b/basis/sequences/deep/deep-tests.factor index 522b5ecdf9..2d3260f427 100644 --- a/basis/sequences/deep/deep-tests.factor +++ b/basis/sequences/deep/deep-tests.factor @@ -24,3 +24,18 @@ IN: sequences.deep.tests [ "foo" ] [ "foo" [ string? ] deep-find ] unit-test [ { { 1 2 } 1 2 } ] [ [ { 1 2 } [ , ] deep-each ] { } make ] unit-test + +[ t ] +[ { { 1 2 3 } 4 } { { { 1 { { 1 2 3 } 4 } } } 2 } deep-member? ] unit-test + +[ t ] +[ { { 1 2 3 } 4 } { { { 1 2 3 } 4 } 2 } deep-member? ] unit-test + +[ f ] +[ { 1 2 3 4 } { 1 2 3 { 4 } } deep-subseq? ] unit-test + +[ t ] +[ { 1 2 3 4 } { 1 2 3 4 } deep-subseq? ] unit-test + +[ t ] +[ { 1 2 3 4 } { { 1 2 3 4 } } deep-subseq? ] unit-test diff --git a/basis/sequences/deep/deep.factor b/basis/sequences/deep/deep.factor index db572681a1..244040d60a 100644 --- a/basis/sequences/deep/deep.factor +++ b/basis/sequences/deep/deep.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2007 Daniel Ehrenberg +! Copyright (C) 2007, 2008 Daniel Ehrenberg, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: sequences kernel strings math ; +USING: sequences kernel strings math fry ; IN: sequences.deep ! All traversal goes in postorder @@ -38,6 +38,16 @@ M: object branch? drop f ; : deep-all? ( obj quot -- ? ) [ not ] compose deep-contains? not ; inline +: deep-member? ( obj seq -- ? ) + swap '[ + _ swap dup branch? [ member? ] [ 2drop f ] if + ] deep-find >boolean ; + +: deep-subseq? ( subseq seq -- ? ) + swap '[ + _ swap dup branch? [ subseq? ] [ 2drop f ] if + ] deep-find >boolean ; + : deep-change-each ( obj quot: ( elt -- elt' ) -- ) over branch? [ [ [ call ] keep over [ deep-change-each ] dip ] curry change-each From 1c27fcc9f32a2d9f1062458c9cc41f56ca4bd2eb Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 11 Dec 2008 23:00:23 -0800 Subject: [PATCH 004/838] docs and metadata for literals --- extra/literals/authors.txt | 1 + extra/literals/literals-docs.factor | 61 ++++++++++++++++++++++++++++ extra/literals/literals-tests.factor | 4 +- extra/literals/literals.factor | 4 +- extra/literals/summary.txt | 1 + extra/literals/tags.txt | 1 + 6 files changed, 70 insertions(+), 2 deletions(-) create mode 100644 extra/literals/authors.txt create mode 100644 extra/literals/literals-docs.factor create mode 100644 extra/literals/summary.txt create mode 100644 extra/literals/tags.txt diff --git a/extra/literals/authors.txt b/extra/literals/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/literals/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/literals/literals-docs.factor b/extra/literals/literals-docs.factor new file mode 100644 index 0000000000..ae25c75495 --- /dev/null +++ b/extra/literals/literals-docs.factor @@ -0,0 +1,61 @@ +! Copyright (C) 2008 Joe Groff. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax multiline ; +IN: literals + +HELP: $ +{ $syntax "$ word" } +{ $description "Executes " { $snippet "word" } " at parse time and adds the result(s) to the parser accumulator." } +{ $notes "Since " { $snippet "word" } " is executed at parse time, " { $snippet "$" } " cannot be used with words defined in the same compilation unit." } +{ $examples + + { $example <" +USING: kernel literals prettyprint ; +IN: scratchpad + +<< : five 5 ; >> +{ $ five } . + "> "{ 5 }" } + + { $example <" +USING: kernel literals prettyprint ; +IN: scratchpad + +<< : seven-eleven 7 11 ; >> +{ $ seven-eleven } . + "> "{ 7 11 }" } + +} ; + +HELP: $[ +{ $syntax "$[ code ]" } +{ $description "Calls " { $snippet "code" } " at parse time and adds the result(s) to the parser accumulator." } +{ $notes "Since " { $snippet "code" } " is executed at parse time, it cannot reference any words defined in the same compilation unit." } +{ $examples + + { $example <" +USING: kernel literals math prettyprint ; +IN: scratchpad + +<< : five 5 ; >> +{ $[ five dup 1+ dup 2 + ] } . + "> "{ 5 6 8 }" } + +} ; + +{ POSTPONE: $ POSTPONE: $[ } related-words + +ARTICLE: "literals" "Interpolating code results into literal values" +"The " { $vocab-link "literals" } " vocabulary contains words to run code at parse time and insert the results into more complex literal values." +{ $example <" +USING: kernel literals math prettyprint ; +IN: scratchpad + +<< : five 5 ; >> +{ $ five $[ five dup 1+ dup 2 + ] } . + "> "{ 5 5 6 8 }" } +{ $subsection POSTPONE: $ } +{ $subsection POSTPONE: $[ } +; + +ABOUT: "literals" diff --git a/extra/literals/literals-tests.factor b/extra/literals/literals-tests.factor index b88a286a59..185d672dd3 100644 --- a/extra/literals/literals-tests.factor +++ b/extra/literals/literals-tests.factor @@ -1,4 +1,4 @@ -USING: kernel literals tools.test ; +USING: kernel literals math tools.test ; IN: literals.tests << @@ -10,3 +10,5 @@ IN: literals.tests [ { 5 } ] [ { $ five } ] unit-test [ { 7 11 } ] [ { $ seven-eleven } ] unit-test [ { 6 6 6 } ] [ { $ six-six-six } ] unit-test + +[ { 8 8 8 } ] [ { $[ six-six-six [ 2 + ] tri@ ] } ] unit-test diff --git a/extra/literals/literals.factor b/extra/literals/literals.factor index d46f492cd4..a450c2118e 100644 --- a/extra/literals/literals.factor +++ b/extra/literals/literals.factor @@ -1,4 +1,6 @@ -USING: continuations kernel parser words ; +! (c) Joe Groff, see license for details +USING: continuations kernel parser words quotations ; IN: literals : $ scan-word [ execute ] curry with-datastack ; parsing +: $[ \ ] parse-until >quotation with-datastack ; parsing diff --git a/extra/literals/summary.txt b/extra/literals/summary.txt new file mode 100644 index 0000000000..dfeb9fe797 --- /dev/null +++ b/extra/literals/summary.txt @@ -0,0 +1 @@ +Expression interpolation into sequence literals diff --git a/extra/literals/tags.txt b/extra/literals/tags.txt new file mode 100644 index 0000000000..71c0ff7282 --- /dev/null +++ b/extra/literals/tags.txt @@ -0,0 +1 @@ +syntax From d2a1a2326bfc73f66d4806fa5fe24e7e319e1c44 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Dec 2008 18:44:43 -0600 Subject: [PATCH 005/838] Use gdb on Windows --- basis/tools/disassembler/disassembler.factor | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/basis/tools/disassembler/disassembler.factor b/basis/tools/disassembler/disassembler.factor index fac340845b..2a717c084f 100644 --- a/basis/tools/disassembler/disassembler.factor +++ b/basis/tools/disassembler/disassembler.factor @@ -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 From 5e6f94ef62b5a875c51d0bdf0d0661c15995853c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Dec 2008 18:49:24 -0600 Subject: [PATCH 006/838] Update iokit for core-foundation split --- extra/iokit/iokit.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/iokit/iokit.factor b/extra/iokit/iokit.factor index 680723def9..2317d21ed5 100755 --- a/extra/iokit/iokit.factor +++ b/extra/iokit/iokit.factor @@ -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 << From d3c279469cd0c09a4673f2f08c39d549cfde0fec Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sat, 13 Dec 2008 01:54:18 +0100 Subject: [PATCH 007/838] FUEL: Asynchronous comms with Factor implemented. Help mode improvements. --- extra/fuel/fuel.factor | 3 +- misc/fuel/README | 9 +- misc/fuel/fuel-base.el | 2 + misc/fuel/fuel-connection.el | 186 +++++++++++++++++++++++++++++++ misc/fuel/fuel-debug.el | 5 +- misc/fuel/fuel-eval.el | 154 ++++++++++++-------------- misc/fuel/fuel-font-lock.el | 2 +- misc/fuel/fuel-help.el | 205 +++++++++++++++++++++++------------ misc/fuel/fuel-listener.el | 26 +++-- misc/fuel/fuel-mode.el | 23 ++-- 10 files changed, 439 insertions(+), 176 deletions(-) create mode 100644 misc/fuel/fuel-connection.el diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index d9db83b5e3..e2535ade30 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -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 diff --git a/misc/fuel/README b/misc/fuel/README index 18f6fa1e94..4dfb16da51 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -50,7 +50,7 @@ Quick key reference (Chords ending in a single letter accept also C- (e.g. C-cC-z is the same as C-cz)). -* In factor files: +* 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 - : 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 diff --git a/misc/fuel/fuel-base.el b/misc/fuel/fuel-base.el index a62d16cb32..9ea1790380 100644 --- a/misc/fuel/fuel-base.el +++ b/misc/fuel/fuel-base.el @@ -59,5 +59,7 @@ " ") len)) +(defsubst empty-string-p (str) (equal str "")) + (provide 'fuel-base) ;;; fuel-base.el ends here diff --git a/misc/fuel/fuel-connection.el b/misc/fuel/fuel-connection.el new file mode 100644 index 0000000000..191424589c --- /dev/null +++ b/misc/fuel/fuel-connection.el @@ -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 +;; 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 diff --git a/misc/fuel/fuel-debug.el b/misc/fuel/fuel-debug.el index b3aad7f3dc..ad9f47ceb1 100644 --- a/misc/fuel/fuel-debug.el +++ b/misc/fuel/fuel-debug.el @@ -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)))) diff --git a/misc/fuel/fuel-eval.el b/misc/fuel/fuel-eval.el index 62001cc48c..02bcb54d66 100644 --- a/misc/fuel/fuel-eval.el +++ b/misc/fuel/fuel-eval.el @@ -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 diff --git a/misc/fuel/fuel-font-lock.el b/misc/fuel/fuel-font-lock.el index 4c710635ba..ba2a499b4b 100644 --- a/misc/fuel/fuel-font-lock.el +++ b/misc/fuel/fuel-font-lock.el @@ -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) diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index 1db9b25d69..227778934a 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -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 diff --git a/misc/fuel/fuel-listener.el b/misc/fuel/fuel-listener.el index 9fa330993c..c72f66b21c 100644 --- a/misc/fuel/fuel-listener.el +++ b/misc/fuel/fuel-listener.el @@ -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) diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index ea1d4b93ed..feaea1548e 100644 --- a/misc/fuel/fuel-mode.el +++ b/misc/fuel/fuel-mode.el @@ -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)))) From a91dee7810a6eeb3003ced2c89e777c37bc7e64b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Dec 2008 19:48:17 -0600 Subject: [PATCH 008/838] Fix for native I/O backends that create callbacks in deployed apps; this affected tools.deploy.test[35] ever since run-loop multiplexer landed on OS X --- basis/stack-checker/alien/alien.factor | 6 ------ core/alien/alien.factor | 8 +++++++- core/io/backend/backend.factor | 4 +++- 3 files changed, 10 insertions(+), 8 deletions(-) diff --git a/basis/stack-checker/alien/alien.factor b/basis/stack-checker/alien/alien.factor index a38e9ea784..f52632040d 100644 --- a/basis/stack-checker/alien/alien.factor +++ b/basis/stack-checker/alien/alien.factor @@ -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 -- ) diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 6a5dfe30df..c97e36e889 100644 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -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 diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor index 5456f2251c..e2c6c3d464 100644 --- a/core/io/backend/backend.factor +++ b/core/io/backend/backend.factor @@ -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 From 8433a9954adb9320066531738da00dce391443da Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Dec 2008 19:48:34 -0600 Subject: [PATCH 009/838] Fix dispose method on run-loop-mx --- basis/io/unix/multiplexers/run-loop/run-loop.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/io/unix/multiplexers/run-loop/run-loop.factor b/basis/io/unix/multiplexers/run-loop/run-loop.factor index 593fe93ac4..7b80e461dc 100644 --- a/basis/io/unix/multiplexers/run-loop/run-loop.factor +++ b/basis/io/unix/multiplexers/run-loop/run-loop.factor @@ -40,8 +40,8 @@ SYMBOL: kqueue-run-loop-source M: run-loop-mx dispose [ { - [ fd>> &dispose drop ] - [ source>> &dispose drop ] + [ fd>> &CFRelease drop ] + [ source>> &CFRelease drop ] [ remove-kqueue-from-run-loop ] [ kqueue-mx>> &dispose drop ] } cleave From 2182bd6422bc87b96bd40f85ae5c06b1a88f82cc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Dec 2008 19:48:51 -0600 Subject: [PATCH 010/838] Add a new deploy test to test callbacks --- basis/tools/deploy/deploy-tests.factor | 5 +++++ basis/tools/deploy/test/3/deploy.factor | 19 ++++++++++--------- basis/tools/deploy/test/9/9.factor | 10 ++++++++++ basis/tools/deploy/test/9/deploy.factor | 15 +++++++++++++++ 4 files changed, 40 insertions(+), 9 deletions(-) create mode 100644 basis/tools/deploy/test/9/9.factor create mode 100644 basis/tools/deploy/test/9/deploy.factor diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index 71dc746fb5..a390ce56c4 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -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 diff --git a/basis/tools/deploy/test/3/deploy.factor b/basis/tools/deploy/test/3/deploy.factor index b38c5da676..c318ac4b6e 100644 --- a/basis/tools/deploy/test/3/deploy.factor +++ b/basis/tools/deploy/test/3/deploy.factor @@ -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 2 } + { deploy-compiler? t } + { deploy-threads? t } + { deploy-io 3 } + { deploy-math? t } + { deploy-word-props? f } + { deploy-c-types? f } } diff --git a/basis/tools/deploy/test/9/9.factor b/basis/tools/deploy/test/9/9.factor new file mode 100644 index 0000000000..a1cbd5bc66 --- /dev/null +++ b/basis/tools/deploy/test/9/9.factor @@ -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 diff --git a/basis/tools/deploy/test/9/deploy.factor b/basis/tools/deploy/test/9/deploy.factor new file mode 100644 index 0000000000..91b1da5697 --- /dev/null +++ b/basis/tools/deploy/test/9/deploy.factor @@ -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 } +} From 115d6e792f9d7be08ee1865ebb02a0ec47b90620 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Dec 2008 19:49:22 -0600 Subject: [PATCH 011/838] Change deploy descriptor back --- basis/tools/deploy/test/3/deploy.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/deploy/test/3/deploy.factor b/basis/tools/deploy/test/3/deploy.factor index c318ac4b6e..f3131237bf 100644 --- a/basis/tools/deploy/test/3/deploy.factor +++ b/basis/tools/deploy/test/3/deploy.factor @@ -5,7 +5,7 @@ H{ { deploy-ui? f } { "stop-after-last-window?" t } { deploy-word-defs? f } - { deploy-reflection 2 } + { deploy-reflection 1 } { deploy-compiler? t } { deploy-threads? t } { deploy-io 3 } From 8be42496b3722a36e316a3d10cbcc2e53325a535 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sat, 13 Dec 2008 03:40:36 +0100 Subject: [PATCH 012/838] FUEL: Ooops, infinite recursion fix. --- misc/fuel/fuel-connection.el | 68 +++++++++++++++++++++++++++++------- misc/fuel/fuel-debug.el | 3 +- misc/fuel/fuel-help.el | 3 +- 3 files changed, 60 insertions(+), 14 deletions(-) diff --git a/misc/fuel/fuel-connection.el b/misc/fuel/fuel-connection.el index 191424589c..247657aa8c 100644 --- a/misc/fuel/fuel-connection.el +++ b/misc/fuel/fuel-connection.el @@ -96,7 +96,8 @@ (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)) + (if (and (cdr current) + (fuel-con--request-deactivated-p (cdr current))) (fuel-con--connection-pop-request c) current))) @@ -113,6 +114,47 @@ (add-hook 'comint-redirect-filter-functions 'fuel-con--comint-redirect-filter t t)) + +;;; Logging: + +(defvar fuel-con--log-size 32000 + "Maximum size of the Factor messages log.") + +(defvar fuel-con--log-verbose-p t + "Log level for Factor messages.") + +(define-derived-mode factor-messages-mode fundamental-mode "Factor Messages" + "Simple mode to log interactions with the factor listener" + (kill-all-local-variables) + (buffer-disable-undo) + (set (make-local-variable 'comint-redirect-subvert-readonly) t) + (add-hook 'after-change-functions + '(lambda (b e len) + (let ((inhibit-read-only t)) + (when (> b fuel-con--log-size) + (delete-region (point-min) b)))) + nil t) + (setq buffer-read-only t)) + +(defun fuel-con--log-buffer () + (or (get-buffer "*factor messages*") + (save-current-buffer + (set-buffer (get-buffer-create "*factor messages*")) + (factor-messages-mode) + (current-buffer)))) + +(defsubst fuel-con--log-msg (type &rest args) + (format "\n%s: %s\n" type (apply 'format args))) + +(defsubst fuel-con--log-warn (&rest args) + (apply 'fuel-con--log-msg 'WARNING args)) + +(defsubst fuel-con--log-error (&rest args) + (apply 'fuel-con--log-msg 'ERROR args)) + +(defsubst fuel-con--log-info (&rest args) + (if fuel-con--log-verbose-p (apply 'fuel-con--log-msg 'INFO args) "")) + ;;; Requests handling: @@ -123,30 +165,32 @@ (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))))) + (when fuel-con--log-verbose-p + (with-current-buffer (fuel-con--log-buffer) + (let ((inhibit-read-only t)) + (insert (fuel-con--log-info "<%s>: %s" + (fuel-con--request-id req) str))))) + (comint-redirect-send-command str (fuel-con--log-buffer) nil t))))) (defun fuel-con--comint-redirect-filter (str) (if (not fuel-con--connection) - (format "\nERROR: No connection in buffer (%s)\n" str) + (fuel-con--log-error "No connection in buffer (%s)" str) (let ((req (fuel-con--connection-current-request fuel-con--connection))) - (if (not req) (format "\nERROR: No current request (%s)\n" str) + (if (not req) (fuel-con--log-error "No current request (%s)" 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) + (fuel-con--log-warn "<%s> Droping result for request %S (%s)" + 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--log-info "<%s>: processed\n\t%s" id str)) + (error (fuel-con--log-error "<%s>: continuation failed %S \n\t%s" + id rstr cerr)))) (fuel-con--connection-clean-current-request fuel-con--connection))))))) diff --git a/misc/fuel/fuel-debug.el b/misc/fuel/fuel-debug.el index ad9f47ceb1..a7c06e4b3e 100644 --- a/misc/fuel/fuel-debug.el +++ b/misc/fuel/fuel-debug.el @@ -253,13 +253,14 @@ invoking restarts as needed. \\{fuel-debug-mode-map}" (interactive) (kill-all-local-variables) + (buffer-disable-undo) (setq major-mode 'factor-mode) (setq mode-name "Fuel Debug") (use-local-map fuel-debug-mode-map) (fuel-debug--font-lock-setup) (setq fuel-debug--file nil) (setq fuel-debug--last-ret nil) - (toggle-read-only 1) + (setq buffer-read-only t) (run-hooks 'fuel-debug-mode-hook)) diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index 227778934a..1d39d1571d 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -261,6 +261,7 @@ buffer." \\{fuel-help-mode-map}" (interactive) (kill-all-local-variables) + (buffer-disable-undo) (use-local-map fuel-help-mode-map) (setq mode-name "Factor Help") (setq major-mode 'fuel-help-mode) @@ -271,7 +272,7 @@ buffer." (fuel-autodoc-mode) (run-mode-hooks 'fuel-help-mode-hook) - (toggle-read-only 1)) + (setq buffer-read-only t)) (provide 'fuel-help) From b3428c61e6560511f4807464c45d02b66d04d563 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Dec 2008 21:06:16 -0600 Subject: [PATCH 013/838] Better bootstrap error handling --- basis/bootstrap/stage2.factor | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index fb7292b989..45a6c354a6 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -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 From 50a78db9bdbac623b63f3b1ac7a8c08ebe50afc0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Dec 2008 21:06:46 -0600 Subject: [PATCH 014/838] Add words for working with CFTimeInterval and CFAbsoluteDate types --- basis/core-foundation/core-foundation.factor | 9 ++++++++- basis/core-foundation/timers/timers.factor | 8 ++++++-- 2 files changed, 14 insertions(+), 3 deletions(-) diff --git a/basis/core-foundation/core-foundation.factor b/basis/core-foundation/core-foundation.factor index 0f64c0666f..51173aff21 100644 --- a/basis/core-foundation/core-foundation.factor +++ b/basis/core-foundation/core-foundation.factor @@ -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 diff --git a/basis/core-foundation/timers/timers.factor b/basis/core-foundation/timers/timers.factor index 049e80b20f..0acd92ced1 100644 --- a/basis/core-foundation/timers/timers.factor +++ b/basis/core-foundation/timers/timers.factor @@ -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 ( ) ; : ( 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 From bb45fa93a713356a27560e5ac53cfee6b87ea6a8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Dec 2008 23:56:19 -0600 Subject: [PATCH 015/838] Add a way to stop the io thread --- basis/io/thread/thread.factor | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/basis/io/thread/thread.factor b/basis/io/thread/thread.factor index fe86ba9e3d..7589d4918e 100644 --- a/basis/io/thread/thread.factor +++ b/basis/io/thread/thread.factor @@ -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 From 5ecffec1b940d2a963f8027da4170dc69ceb9820 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Dec 2008 23:57:16 -0600 Subject: [PATCH 016/838] Clean up run loop I/O multiplexer and make most of it independent of the I/O system; the UI will use it too --- .../core-foundation/run-loop/run-loop.factor | 84 ++++++++++++++++++- .../multiplexers/run-loop/run-loop.factor | 47 +++-------- 2 files changed, 92 insertions(+), 39 deletions(-) diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor index 475991a246..5f2ff7bd53 100644 --- a/basis/core-foundation/run-loop/run-loop.factor +++ b/basis/core-foundation/run-loop/run-loop.factor @@ -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" dup \ CFRunLoopDefaultMode set-global ] when ; + +TUPLE: run-loop fds sources timers ; + +: ( -- 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 expiry-check set-global + 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 -- ) + [ + |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 ; + +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 add-timer-to-run-loop ; + +: run-one-iteration ( us -- handled? ) + reset-run-loop + CFRunLoopDefaultMode + swap [ microseconds ] [ 5 minutes ] if* >CFTimeInterval + t CFRunLoopRunInMode kCFRunLoopRunHandledSource = ; diff --git a/basis/io/unix/multiplexers/run-loop/run-loop.factor b/basis/io/unix/multiplexers/run-loop/run-loop.factor index 7b80e461dc..4b2486d19f 100644 --- a/basis/io/unix/multiplexers/run-loop/run-loop.factor +++ b/basis/io/unix/multiplexers/run-loop/run-loop.factor @@ -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 ; : ( -- mx ) [ |dispose - dup fd>> kqueue-callback |dispose - dup create-kqueue-source run-loop-mx boa - dup add-kqueue-to-run-loop - ] with-destructors ; - -M: run-loop-mx dispose - [ - { - [ fd>> &CFRelease drop ] - [ source>> &CFRelease 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 ; From 323de69e88afcee35d2ebb1dbcb391da6d6d8199 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Dec 2008 23:57:28 -0600 Subject: [PATCH 017/838] Remove obsolete tests --- basis/io/unix/multiplexers/run-loop/run-loop-tests.factor | 5 ----- 1 file changed, 5 deletions(-) delete mode 100644 basis/io/unix/multiplexers/run-loop/run-loop-tests.factor diff --git a/basis/io/unix/multiplexers/run-loop/run-loop-tests.factor b/basis/io/unix/multiplexers/run-loop/run-loop-tests.factor deleted file mode 100644 index 5f249c6881..0000000000 --- a/basis/io/unix/multiplexers/run-loop/run-loop-tests.factor +++ /dev/null @@ -1,5 +0,0 @@ -USING: io.unix.multiplexers.run-loop tools.test -destructors ; -IN: io.unix.multiplexers.run-loop.tests - -[ ] [ dispose ] unit-test From 053c15e476d7548551717b1a782650f875aa4628 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Dec 2008 23:58:28 -0600 Subject: [PATCH 018/838] This is where all the recent I/O and core foundation work comes together: use core-foundation.run-loop to receive events on Mac OS X instead of weak-ass Squeak-style polling every 10ms --- basis/ui/backend/backend.factor | 2 -- basis/ui/cocoa/cocoa.factor | 19 ++++++++++--------- basis/ui/event-loop/event-loop.factor | 19 +++++++++++++++++++ basis/ui/ui.factor | 13 ------------- basis/ui/windows/windows.factor | 12 ++++++------ basis/ui/x11/x11.factor | 6 +++--- 6 files changed, 38 insertions(+), 33 deletions(-) create mode 100644 basis/ui/event-loop/event-loop.factor diff --git a/basis/ui/backend/backend.factor b/basis/ui/backend/backend.factor index aa84419d64..eaa0953d25 100755 --- a/basis/ui/backend/backend.factor +++ b/basis/ui/backend/backend.factor @@ -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 -- ) diff --git a/basis/ui/cocoa/cocoa.factor b/basis/ui/cocoa/cocoa.factor index fecbb52a25..331c0a698c 100755 --- a/basis/ui/cocoa/cocoa.factor +++ b/basis/ui/cocoa/cocoa.factor @@ -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 SINGLETON: cocoa-ui-backend -M: cocoa-ui-backend do-events ( -- ) - [ NSApp '[ _ do-event ] loop ui-wait ] with-autorelease-pool ; - TUPLE: pasteboard handle ; C: 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 ; diff --git a/basis/ui/event-loop/event-loop.factor b/basis/ui/event-loop/event-loop.factor new file mode 100644 index 0000000000..fe6f4d7de5 --- /dev/null +++ b/basis/ui/event-loop/event-loop.factor @@ -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 ; diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 1ee860c974..b6bc172c21 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -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 -- ) diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor index 35ee9f9a60..7f68bb5736 100755 --- a/basis/ui/windows/windows.factor +++ b/basis/ui/windows/windows.factor @@ -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 diff --git a/basis/ui/x11/x11.factor b/basis/ui/x11/x11.factor index 817e356712..9be3c2fd10 100755 --- a/basis/ui/x11/x11.factor +++ b/basis/ui/x11/x11.factor @@ -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 ; From a4ba0453b3a32de5200fc9a114bfc54500e861de Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 13 Dec 2008 00:00:39 -0600 Subject: [PATCH 019/838] Fix UI docs --- basis/ui/ui-docs.factor | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor index 738d259cad..64a98fee03 100644 --- a/basis/ui/ui-docs.factor +++ b/basis/ui/ui-docs.factor @@ -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:" From 7ad494d2dd2382e0711cff6f3d8cc32f2ad655e7 Mon Sep 17 00:00:00 2001 From: slava Date: Sat, 13 Dec 2008 00:09:36 -0600 Subject: [PATCH 020/838] Add Display structure --- basis/x11/xlib/xlib.factor | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/basis/x11/xlib/xlib.factor b/basis/x11/xlib/xlib.factor index 555eb573fc..58b4995c40 100644 --- a/basis/x11/xlib/xlib.factor +++ b/basis/x11/xlib/xlib.factor @@ -31,7 +31,6 @@ TYPEDEF: XID KeySym TYPEDEF: ulong Atom TYPEDEF: char* XPointer -TYPEDEF: void* Display* TYPEDEF: void* Screen* TYPEDEF: void* GC TYPEDEF: void* Visual* @@ -66,6 +65,12 @@ TYPEDEF: void* Atom** ! 2 - Display Functions ! +! This struct is incomplete +C-STRUCT: Display +{ "void*" "ext_data" } +{ "void*" "free_funcs" } +{ "int" "fd" } ; + FUNCTION: Display* XOpenDisplay ( void* display_name ) ; ! 2.2 Obtaining Information about the Display, Image Formats, or Screens From 7bf857650c322290e5445e1d8113f4527f03adcf Mon Sep 17 00:00:00 2001 From: slava Date: Sat, 13 Dec 2008 03:49:22 -0600 Subject: [PATCH 021/838] Remove stop-after-last-window? option, it's obsolete, get ui.event-loop (only used on X11 and Windows) to load --- basis/tools/deploy/shaker/strip-cocoa.factor | 4 ---- basis/ui/event-loop/event-loop.factor | 7 +++---- basis/ui/tools/deploy/deploy.factor | 5 ----- basis/ui/ui.factor | 3 --- basis/ui/windows/windows.factor | 1 - 5 files changed, 3 insertions(+), 17 deletions(-) diff --git a/basis/tools/deploy/shaker/strip-cocoa.factor b/basis/tools/deploy/shaker/strip-cocoa.factor index 773b2d0f3b..df64443b7b 100644 --- a/basis/tools/deploy/shaker/strip-cocoa.factor +++ b/basis/tools/deploy/shaker/strip-cocoa.factor @@ -19,12 +19,8 @@ IN: cocoa.application [ [ die ] 19 setenv ] "cocoa.application" add-init-hook -"stop-after-last-window?" get - H{ } clone \ pool [ global [ - "stop-after-last-window?" "ui" lookup set - ! Only keeps those methods that we actually call sent-messages get super-sent-messages get assoc-union objc-methods [ assoc-intersect pool-values ] change diff --git a/basis/ui/event-loop/event-loop.factor b/basis/ui/event-loop/event-loop.factor index fe6f4d7de5..7c08d802f5 100644 --- a/basis/ui/event-loop/event-loop.factor +++ b/basis/ui/event-loop/event-loop.factor @@ -1,12 +1,11 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: ui.backend kernel namespaces sequences deques calendar -threads ; +USING: calendar combinators deques kernel namespaces sequences +threads ui ui.backend ui.gadgets ; 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 ] @@ -14,6 +13,6 @@ IN: ui.event-loop HOOK: do-events ui-backend ( -- ) -: event-loop ( quot -- ) [ event-loop? ] [ do-events ] [ ] while ; +: event-loop ( -- ) [ event-loop? ] [ do-events ] [ ] while ; : ui-wait ( -- ) 10 milliseconds sleep ; diff --git a/basis/ui/tools/deploy/deploy.factor b/basis/ui/tools/deploy/deploy.factor index f233c9f162..38db81c3dc 100644 --- a/basis/ui/tools/deploy/deploy.factor +++ b/basis/ui/tools/deploy/deploy.factor @@ -18,10 +18,6 @@ TUPLE: deploy-gadget < pack vocab settings ; deploy-ui? get "Include user interface framework" add-gadget ; -: exit-when-windows-closed ( parent -- parent ) - "stop-after-last-window?" get - "Exit when last UI window closed" add-gadget ; - : io-settings ( parent -- parent ) "Input/output support:"