From 416f46db7cb1abb25c3156e89a14785cdb9db282 Mon Sep 17 00:00:00 2001
From: "Jose A. Ortega Ruiz" <jao@gnu.org>
Date: Wed, 17 Dec 2008 21:44:41 +0100
Subject: [PATCH 01/15] FUEL: More simplifications and small speed-ups in
listener/emacs communications.
---
misc/fuel/fuel-base.el | 5 ++++
misc/fuel/fuel-completion.el | 21 +++++++++++++---
misc/fuel/fuel-connection.el | 47 ++++++++++++++++++------------------
misc/fuel/fuel-eval.el | 12 ++++-----
misc/fuel/fuel-help.el | 2 --
5 files changed, 51 insertions(+), 36 deletions(-)
diff --git a/misc/fuel/fuel-base.el b/misc/fuel/fuel-base.el
index f60c5f241d..aa9614da0a 100644
--- a/misc/fuel/fuel-base.el
+++ b/misc/fuel/fuel-base.el
@@ -61,6 +61,11 @@
(defsubst empty-string-p (str) (equal str ""))
+(defun fuel--string-prefix-p (prefix str)
+ (and (>= (length str) (length prefix))
+ (string= (substring-no-properties 0 (length prefix) str)
+ (substring-no-properties prefix))))
+
(defun fuel--respecting-message (format &rest format-args)
"Display TEXT as a message, without hiding any minibuffer contents."
(let ((text (format " [%s]" (apply #'format format format-args))))
diff --git a/misc/fuel/fuel-completion.el b/misc/fuel/fuel-completion.el
index 8d2d779b31..a2b617672f 100644
--- a/misc/fuel/fuel-completion.el
+++ b/misc/fuel/fuel-completion.el
@@ -32,11 +32,24 @@
(fuel-eval--send/wait '(:fuel* (fuel-get-vocabs) "fuel" (:array)))))))
fuel-completion--vocabs)
+(defvar fuel-completion--words-last (cons nil nil))
+
+(defsubst fuel-completion--forget-words ()
+ (setq fuel-completion--words-last (cons nil nil)))
+
(defun fuel-completion--words (prefix vocabs)
(let ((vs (if vocabs (cons :array vocabs) 'f))
(us (or vocabs 't)))
- (fuel-eval--retort-result
- (fuel-eval--send/wait `(:fuel* (,prefix ,vs fuel-get-words) t ,us)))))
+ (if (and (car fuel-completion--words-last)
+ (cdr fuel-completion--words-last)
+ (equal (caar fuel-completion--words-last) vs)
+ (fuel--string-prefix-p (cdar fuel-completion--words-last) prefix))
+ (cdr fuel-completion--words-last)
+ (setcar fuel-completion--words-last (cons vocabs prefix))
+ (setcdr fuel-completion--words-last
+ (fuel-eval--retort-result
+ (fuel-eval--send/wait
+ `(:fuel* (,prefix ,vs fuel-get-words) t ,us)))))))
;;; Completions window handling, heavily inspired in slime's:
@@ -159,7 +172,8 @@ terminates a current completion."
(partial (if (eq partial t) prefix partial)))
(cons completions partial)))
-(defsubst fuel-completion--read-word (prompt &optional default history all)
+(defun fuel-completion--read-word (prompt &optional default history all)
+ (fuel-completion--forget-words)
(completing-read prompt
(if all fuel-completion--all-words-list-func
fuel-completion--word-list-func)
@@ -171,6 +185,7 @@ terminates a current completion."
"Complete the symbol at point.
Perform completion similar to Emacs' complete-symbol."
(interactive)
+ (fuel-completion--forget-words)
(let* ((end (point))
(beg (fuel-syntax--symbol-start))
(prefix (buffer-substring-no-properties beg end))
diff --git a/misc/fuel/fuel-connection.el b/misc/fuel/fuel-connection.el
index da621b3beb..641e1833b9 100644
--- a/misc/fuel/fuel-connection.el
+++ b/misc/fuel/fuel-connection.el
@@ -143,12 +143,11 @@
(defconst fuel-con--init-stanza (format "USE: fuel %S write" fuel-con--eot-marker))
(defconst fuel-con--comint-finished-regex
- (format "%s%s" fuel-con--eot-marker fuel-con--prompt-regex))
+ (format "^%s%s$" fuel-con--eot-marker fuel-con--prompt-regex))
(defun fuel-con--setup-comint ()
(comint-redirect-cleanup)
- (add-hook 'comint-redirect-filter-functions
- 'fuel-con--comint-redirect-filter t t)
+ (set (make-local-variable 'comint-redirect-insert-matching-regexp) t)
(add-hook 'comint-redirect-hook
'fuel-con--comint-redirect-hook nil t))
@@ -158,45 +157,45 @@
;;; Requests handling:
+(defsubst fuel-con--comint-buffer ()
+ (get-buffer-create " *fuel connection retort*"))
+
+(defsubst fuel-con--comint-buffer-form ()
+ (with-current-buffer (fuel-con--comint-buffer)
+ (goto-char (point-min))
+ (condition-case nil
+ (read (current-buffer))
+ (error (list 'fuel-con-error (buffer-string))))))
+
(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))))
+ (str (and req (fuel-con--request-string req)))
+ (cbuf (with-current-buffer (fuel-con--comint-buffer)
+ (erase-buffer)
+ (current-buffer))))
(if (not (buffer-live-p buffer))
(fuel-con--connection-cancel-timer con)
(when (and buffer req str)
(set-buffer buffer)
(fuel-log--info "<%s>: %s" (fuel-con--request-id req) str)
- (comint-redirect-send-command (format "%s" str)
- (fuel-log--buffer) nil t))))))
+ (comint-redirect-send-command (format "%s" str) cbuf nil t))))))
(defun fuel-con--process-completed-request (req)
- (let ((str (fuel-con--request-output req))
- (cont (fuel-con--request-continuation req))
+ (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)))
(if (not cont)
(fuel-log--warn "<%s> Droping result for request %S (%s)"
- id rstr str)
+ id rstr req)
(condition-case cerr
(with-current-buffer (or buffer (current-buffer))
- (funcall cont str)
- (fuel-log--info "<%s>: processed\n\t%s" id str))
- (error (fuel-log--error "<%s>: continuation failed %S \n\t%s"
- id rstr cerr))))))
-
-(defvar fuel-con--debug-comint-p nil)
-
-(defun fuel-con--comint-redirect-filter (str)
- (if (not fuel-con--connection)
- (fuel-log--error "No connection in buffer (%s)" str)
- (let ((req (fuel-con--connection-current-request fuel-con--connection)))
- (if (not req) (fuel-log--error "No current request (%s)" str)
- (fuel-con--request-output req str)
- (fuel-log--info "<%s>: in progress" (fuel-con--request-id req)))))
- (if fuel-con--debug-comint-p (fuel--shorten-str str 256) ""))
+ (funcall cont (fuel-con--comint-buffer-form))
+ (fuel-log--info "<%s>: processed\n\t%s" id req))
+ (error (fuel-log--error
+ "<%s>: continuation failed %S \n\t%s" id rstr cerr))))))
(defun fuel-con--comint-redirect-hook ()
(if (not fuel-con--connection)
diff --git a/misc/fuel/fuel-eval.el b/misc/fuel/fuel-eval.el
index ca71012ec5..a77de0ba2e 100644
--- a/misc/fuel/fuel-eval.el
+++ b/misc/fuel/fuel-eval.el
@@ -115,17 +115,15 @@
(defsubst fuel-eval--retort-result (ret) (nth 1 ret))
(defsubst fuel-eval--retort-output (ret) (nth 2 ret))
-(defsubst fuel-eval--retort-p (ret) (listp ret))
+(defsubst fuel-eval--retort-p (ret)
+ (and (listp ret) (= 3 (length ret))))
(defsubst fuel-eval--make-parse-error-retort (str)
(fuel-eval--retort-make (cons 'fuel-parse-retort-error str) nil))
-(defun fuel-eval--parse-retort (str)
- (save-current-buffer
- (condition-case nil
- (let ((ret (car (read-from-string str))))
- (if (fuel-eval--retort-p ret) ret (error)))
- (error (fuel-eval--make-parse-error-retort str)))))
+(defun fuel-eval--parse-retort (ret)
+ (if (fuel-eval--retort-p ret) ret
+ (fuel-eval--make-parse-error-retort ret)))
(defsubst fuel-eval--error-name (err) (car err))
diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el
index 1b0890ef9b..f0e02df4f1 100644
--- a/misc/fuel/fuel-help.el
+++ b/misc/fuel/fuel-help.el
@@ -176,8 +176,6 @@ displayed in the minibuffer."
(when (re-search-forward (format "^%s" def) nil t)
(beginning-of-line)
(kill-region (point-min) (point))
- (next-line)
- (open-line 1)
(fuel-help--history-push (cons def (buffer-string)))))
(set-buffer-modified-p nil)
(pop-to-buffer hb)
From de37d913043cb1e0c711988c605d26cb51a61e95 Mon Sep 17 00:00:00 2001
From: "Jose A. Ortega Ruiz" <jao@gnu.org>
Date: Wed, 17 Dec 2008 23:50:48 +0100
Subject: [PATCH 02/15] FUEL: Bug fixes and compatibility with Emacs 22.
---
extra/fuel/fuel.factor | 10 +++++++++-
misc/fuel/fuel-base.el | 9 +++++++++
misc/fuel/fuel-completion.el | 19 ++-----------------
misc/fuel/fuel-eval.el | 3 ++-
misc/fuel/fuel-help.el | 4 +++-
misc/fuel/fuel-mode.el | 23 ++++++++++++++++++-----
6 files changed, 43 insertions(+), 25 deletions(-)
diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor
index 4535ac7fd6..15b9adf870 100644
--- a/extra/fuel/fuel.factor
+++ b/extra/fuel/fuel.factor
@@ -168,12 +168,20 @@ M: source-file fuel-pprint path>> fuel-pprint ;
: fuel-get-vocab-location ( vocab -- )
>vocab-link fuel-get-edit-location ; inline
+! Completion support
+
+: fuel-filter-prefix ( seq prefix -- seq )
+ [ drop-prefix nip length 0 = ] curry filter ; inline
+
: (fuel-get-vocabs) ( -- seq )
all-vocabs-seq [ vocab-name ] map ; inline
: fuel-get-vocabs ( -- )
(fuel-get-vocabs) fuel-eval-set-result ; inline
+: fuel-get-vocabs/prefix ( prefix -- )
+ (fuel-get-vocabs) swap fuel-filter-prefix fuel-eval-set-result ; inline
+
MEMO: (fuel-vocab-words) ( name -- seq )
>vocab-link words [ name>> ] map ;
@@ -185,7 +193,7 @@ MEMO: (fuel-vocab-words) ( name -- seq )
: (fuel-get-words) ( prefix names/f -- seq )
[ fuel-vocabs-words ] [ fuel-current-words ] if* natural-sort
- swap [ drop-prefix nip length 0 = ] curry filter ;
+ swap fuel-filter-prefix ;
: fuel-get-words ( prefix names -- )
(fuel-get-words) fuel-eval-set-result ; inline
diff --git a/misc/fuel/fuel-base.el b/misc/fuel/fuel-base.el
index aa9614da0a..1a7cf4fbe6 100644
--- a/misc/fuel/fuel-base.el
+++ b/misc/fuel/fuel-base.el
@@ -39,6 +39,15 @@
(when (equal item (ring-ref ring ind))
(throw 'found ind)))))))
+(when (not (fboundp 'completion-table-dynamic))
+ (defun completion-table-dynamic (fun)
+ (lexical-let ((fun fun))
+ (lambda (string pred action)
+ (with-current-buffer (let ((win (minibuffer-selected-window)))
+ (if (window-live-p win) (window-buffer win)
+ (current-buffer)))
+ (complete-with-action action (funcall fun string) string pred))))))
+
;;; Utilities
diff --git a/misc/fuel/fuel-completion.el b/misc/fuel/fuel-completion.el
index a2b617672f..a4f467fd98 100644
--- a/misc/fuel/fuel-completion.el
+++ b/misc/fuel/fuel-completion.el
@@ -32,24 +32,11 @@
(fuel-eval--send/wait '(:fuel* (fuel-get-vocabs) "fuel" (:array)))))))
fuel-completion--vocabs)
-(defvar fuel-completion--words-last (cons nil nil))
-
-(defsubst fuel-completion--forget-words ()
- (setq fuel-completion--words-last (cons nil nil)))
-
(defun fuel-completion--words (prefix vocabs)
(let ((vs (if vocabs (cons :array vocabs) 'f))
(us (or vocabs 't)))
- (if (and (car fuel-completion--words-last)
- (cdr fuel-completion--words-last)
- (equal (caar fuel-completion--words-last) vs)
- (fuel--string-prefix-p (cdar fuel-completion--words-last) prefix))
- (cdr fuel-completion--words-last)
- (setcar fuel-completion--words-last (cons vocabs prefix))
- (setcdr fuel-completion--words-last
- (fuel-eval--retort-result
- (fuel-eval--send/wait
- `(:fuel* (,prefix ,vs fuel-get-words) t ,us)))))))
+ (fuel-eval--retort-result
+ (fuel-eval--send/wait `(:fuel* (,prefix ,vs fuel-get-words) t ,us)))))
;;; Completions window handling, heavily inspired in slime's:
@@ -173,7 +160,6 @@ terminates a current completion."
(cons completions partial)))
(defun fuel-completion--read-word (prompt &optional default history all)
- (fuel-completion--forget-words)
(completing-read prompt
(if all fuel-completion--all-words-list-func
fuel-completion--word-list-func)
@@ -185,7 +171,6 @@ terminates a current completion."
"Complete the symbol at point.
Perform completion similar to Emacs' complete-symbol."
(interactive)
- (fuel-completion--forget-words)
(let* ((end (point))
(beg (fuel-syntax--symbol-start))
(prefix (buffer-substring-no-properties beg end))
diff --git a/misc/fuel/fuel-eval.el b/misc/fuel/fuel-eval.el
index a77de0ba2e..871d8c0ae6 100644
--- a/misc/fuel/fuel-eval.el
+++ b/misc/fuel/fuel-eval.el
@@ -66,7 +66,8 @@
(defsubst factor--fuel-in (in)
(cond ((null in) :in)
- ((eq in t) "fuel-scratchpad")
+ ((eq in 'f) 'f)
+ ((eq in 't) "fuel-scratchpad")
((stringp in) in)
(t (error "Invalid 'in' (%s)" in))))
diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el
index f0e02df4f1..e618fd130a 100644
--- a/misc/fuel/fuel-help.el
+++ b/misc/fuel/fuel-help.el
@@ -152,7 +152,8 @@ displayed in the minibuffer."
fuel-help-always-ask))
(def (if ask (fuel-completion--read-word prompt
def
- 'fuel-help--prompt-history)
+ 'fuel-help--prompt-history
+ t)
def))
(cmd `(:fuel* ((:quote ,def) ,(if see 'see 'help)) t)))
(message "Looking up '%s' ..." def)
@@ -229,6 +230,7 @@ buffer."
(define-key map "b" 'fuel-help-previous)
(define-key map "f" 'fuel-help-next)
(define-key map "l" 'fuel-help-previous)
+ (define-key map "p" 'fuel-help-previous)
(define-key map "n" 'fuel-help-next)
(define-key map (kbd "SPC") 'scroll-up)
(define-key map (kbd "S-SPC") 'scroll-down)
diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el
index b931605183..265cfde0a2 100644
--- a/misc/fuel/fuel-mode.el
+++ b/misc/fuel/fuel-mode.el
@@ -39,14 +39,24 @@
;;; User commands
-(defun fuel-run-file (&optional arg)
- "Sends the current file to Factor for compilation.
-With prefix argument, ask for the file to run."
- (interactive "P")
+(defun fuel-mode--read-file (arg)
(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)))
+ (when (and buffer
+ (buffer-modified-p buffer)
+ (y-or-n-p "Save file? "))
+ (save-buffer buffer))
+ (cons file buffer)))
+
+(defun fuel-run-file (&optional arg)
+ "Sends the current file to Factor for compilation.
+With prefix argument, ask for the file to run."
+ (interactive "P")
+ (let* ((f/b (fuel-mode--read-file arg))
+ (file (car f/b))
+ (buffer (cdr f/b)))
(when buffer
(with-current-buffer buffer
(message "Compiling %s ..." file)
@@ -61,6 +71,7 @@ With prefix argument, ask for the file to run."
(message "Compiling %s ... OK!" file)
(message "")))
+
(defun fuel-eval-region (begin end &optional arg)
"Sends region to Fuel's listener for evaluation.
Unless called with a prefix, switchs to the compilation results
@@ -191,9 +202,10 @@ interacting with a factor listener is at your disposal.
(define-key fuel-mode-map (vector '(control ?c) `(control ,p) k) c)
(define-key fuel-mode-map (vector '(control ?c) `(control ,p) `(control ,k)) c))
-(fuel-mode--key-1 ?z 'run-factor)
(fuel-mode--key-1 ?k 'fuel-run-file)
+(fuel-mode--key-1 ?l 'fuel-run-file)
(fuel-mode--key-1 ?r 'fuel-eval-region)
+(fuel-mode--key-1 ?z 'run-factor)
(define-key fuel-mode-map "\C-\M-x" 'fuel-eval-definition)
(define-key fuel-mode-map "\C-\M-r" 'fuel-eval-extended-region)
@@ -201,6 +213,7 @@ interacting with a factor listener is at your disposal.
(define-key fuel-mode-map (kbd "M-TAB") 'fuel-completion--complete-symbol)
(fuel-mode--key ?e ?e 'fuel-eval-extended-region)
+(fuel-mode--key ?e ?l 'fuel-run-file)
(fuel-mode--key ?e ?r 'fuel-eval-region)
(fuel-mode--key ?e ?v 'fuel-edit-vocabulary)
(fuel-mode--key ?e ?w 'fuel-edit-word)
From 2cc6810ea6ec731503396aedbc5fcad0961a901f Mon Sep 17 00:00:00 2001
From: "Jose A. Ortega Ruiz" <jao@gnu.org>
Date: Thu, 18 Dec 2008 00:49:01 +0100
Subject: [PATCH 03/15] FUEL: M-. completes vocab names when in USING: stanza.
---
extra/fuel/fuel.factor | 4 +++-
misc/fuel/fuel-completion.el | 12 +++++++++---
misc/fuel/fuel-connection.el | 8 +-------
misc/fuel/fuel-syntax.el | 7 +++++++
4 files changed, 20 insertions(+), 11 deletions(-)
diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor
index 15b9adf870..dacf57cc7f 100644
--- a/extra/fuel/fuel.factor
+++ b/extra/fuel/fuel.factor
@@ -160,6 +160,8 @@ M: source-file fuel-pprint path>> fuel-pprint ;
: fuel-end-eval ( -- ) [ ] (fuel-end-eval) ; inline
+! Edit locations
+
: fuel-get-edit-location ( defspec -- )
where [
first2 [ (normalize-path) ] dip 2array fuel-eval-set-result
@@ -193,7 +195,7 @@ MEMO: (fuel-vocab-words) ( name -- seq )
: (fuel-get-words) ( prefix names/f -- seq )
[ fuel-vocabs-words ] [ fuel-current-words ] if* natural-sort
- swap fuel-filter-prefix ;
+ swap fuel-filter-prefix ;
: fuel-get-words ( prefix names -- )
(fuel-get-words) fuel-eval-set-result ; inline
diff --git a/misc/fuel/fuel-completion.el b/misc/fuel/fuel-completion.el
index a4f467fd98..c7340c7037 100644
--- a/misc/fuel/fuel-completion.el
+++ b/misc/fuel/fuel-completion.el
@@ -32,6 +32,10 @@
(fuel-eval--send/wait '(:fuel* (fuel-get-vocabs) "fuel" (:array)))))))
fuel-completion--vocabs)
+(defsubst fuel-completion--vocab-list (prefix)
+ (fuel-eval--retort-result
+ (fuel-eval--send/wait `(:fuel* (,prefix fuel-get-vocabs/prefix) t t))))
+
(defun fuel-completion--words (prefix vocabs)
(let ((vs (if vocabs (cons :array vocabs) 'f))
(us (or vocabs 't)))
@@ -152,8 +156,10 @@ terminates a current completion."
(defvar fuel-completion--all-words-list-func
(completion-table-dynamic 'fuel-completion--all-words-list))
-(defun fuel-completion--complete (prefix)
- (let* ((words (fuel-completion--word-list prefix))
+(defun fuel-completion--complete (prefix vocabs)
+ (let* ((words (if vocabs
+ (fuel-completion--vocabs)
+ (fuel-completion--word-list prefix)))
(completions (all-completions prefix words))
(partial (try-completion prefix words))
(partial (if (eq partial t) prefix partial)))
@@ -174,7 +180,7 @@ Perform completion similar to Emacs' complete-symbol."
(let* ((end (point))
(beg (fuel-syntax--symbol-start))
(prefix (buffer-substring-no-properties beg end))
- (result (fuel-completion--complete prefix))
+ (result (fuel-completion--complete prefix (fuel-syntax--in-using)))
(completions (car result))
(partial (cdr result)))
(cond ((null completions)
diff --git a/misc/fuel/fuel-connection.el b/misc/fuel/fuel-connection.el
index 641e1833b9..3cac40bd16 100644
--- a/misc/fuel/fuel-connection.el
+++ b/misc/fuel/fuel-connection.el
@@ -46,8 +46,7 @@
(cons :id (random))
(cons :string str)
(cons :continuation cont)
- (cons :buffer (or sender-buffer (current-buffer)))
- (cons :output "")))
+ (cons :buffer (or sender-buffer (current-buffer)))))
(defsubst fuel-con--request-p (req)
(and (listp req) (eq (car req) :fuel-connection-request)))
@@ -64,11 +63,6 @@
(defsubst fuel-con--request-buffer (req)
(cdr (assoc :buffer req)))
-(defun fuel-con--request-output (req &optional suffix)
- (let ((cell (assoc :output req)))
- (when suffix (setcdr cell (concat (cdr cell) suffix)))
- (cdr cell)))
-
(defsubst fuel-con--request-deactivate (req)
(setcdr (assoc :continuation req) nil))
diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el
index 936bded3a5..7785c043df 100644
--- a/misc/fuel/fuel-syntax.el
+++ b/misc/fuel/fuel-syntax.el
@@ -232,6 +232,13 @@
(defsubst fuel-syntax--at-using ()
(looking-at fuel-syntax--using-lines-regex))
+(defun fuel-syntax--in-using ()
+ (let ((p (point)))
+ (save-excursion
+ (and (re-search-backward "^USING: " nil t)
+ (re-search-forward " ;" nil t)
+ (< p (match-end 0))))))
+
(defsubst fuel-syntax--beginning-of-defun (&optional times)
(re-search-backward fuel-syntax--begin-of-def-regex nil t times))
From 194d0cec41c35b049c150849c50e32c027a099ed Mon Sep 17 00:00:00 2001
From: "Jose A. Ortega Ruiz" <jao@gnu.org>
Date: Thu, 18 Dec 2008 12:11:59 +0100
Subject: [PATCH 04/15] FUEL: Font lock for getters/setters fixed, with faces
for both.
---
misc/fuel/factor-mode.el | 17 -----------------
misc/fuel/fuel-font-lock.el | 20 ++++++++++++++++++--
misc/fuel/fuel-syntax.el | 6 ++++--
3 files changed, 22 insertions(+), 21 deletions(-)
diff --git a/misc/fuel/factor-mode.el b/misc/fuel/factor-mode.el
index 8cf578f090..2f6eef4f65 100644
--- a/misc/fuel/factor-mode.el
+++ b/misc/fuel/factor-mode.el
@@ -59,23 +59,6 @@ code in the buffer."
:type 'hook
:group 'factor-mode)
-
-;;; Faces:
-
-(fuel-font-lock--define-faces
- factor-font-lock font-lock factor-mode
- ((comment comment "comments")
- (constructor type "constructors (<foo>)")
- (declaration keyword "declaration words")
- (parsing-word keyword "parsing words")
- (setter-word function-name "setter words (>>foo)")
- (stack-effect comment "stack effect specifications")
- (string string "strings")
- (symbol variable-name "name of symbol being defined")
- (type-name type "type names")
- (vocabulary-name constant "vocabulary names")
- (word function-name "word, generic or method being defined")))
-
;;; Syntax table:
diff --git a/misc/fuel/fuel-font-lock.el b/misc/fuel/fuel-font-lock.el
index ba2a499b4b..616bff2def 100644
--- a/misc/fuel/fuel-font-lock.el
+++ b/misc/fuel/fuel-font-lock.el
@@ -13,8 +13,8 @@
;;; Code:
-(require 'fuel-base)
(require 'fuel-syntax)
+(require 'fuel-base)
(require 'font-lock)
@@ -39,6 +39,21 @@
',faces)))
(,setup))))
+(fuel-font-lock--define-faces
+ factor-font-lock font-lock factor-mode
+ ((comment comment "comments")
+ (constructor type "constructors (<foo>)")
+ (declaration keyword "declaration words")
+ (parsing-word keyword "parsing words")
+ (setter-word function-name "setter words (>>foo)")
+ (getter-word function-name "getter words (foo>>)")
+ (stack-effect comment "stack effect specifications")
+ (string string "strings")
+ (symbol variable-name "name of symbol being defined")
+ (type-name type "type names")
+ (vocabulary-name constant "vocabulary names")
+ (word function-name "word, generic or method being defined")))
+
;;; Font lock:
@@ -59,7 +74,8 @@
(2 'factor-font-lock-word))
(,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--setter-regex 2 'factor-font-lock-setter-word)
+ (,fuel-syntax--getter-regex 2 'factor-font-lock-getter-word)
(,fuel-syntax--symbol-definition-regex 2 'factor-font-lock-symbol)
(,fuel-syntax--use-line-regex 1 'factor-font-lock-vocabulary-name))
"Font lock keywords definition for Factor mode.")
diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el
index 7785c043df..e810772bd0 100644
--- a/misc/fuel/fuel-syntax.el
+++ b/misc/fuel/fuel-syntax.el
@@ -64,7 +64,8 @@
'("flushable" "foldable" "inline" "parsing" "recursive"))
(defconst fuel-syntax--declaration-words-regex
- (regexp-opt fuel-syntax--declaration-words 'words))
+ (format "%s\\($\\| \\)"
+ (regexp-opt fuel-syntax--declaration-words 'words)))
(defsubst fuel-syntax--second-word-regex (prefixes)
(format "^%s +\\([^ \r\n]+\\)" (regexp-opt prefixes t)))
@@ -82,7 +83,8 @@
(defconst fuel-syntax--constructor-regex "<[^ >]+>")
-(defconst fuel-syntax--setter-regex "\\W>>[^ ]+\\b")
+(defconst fuel-syntax--getter-regex "\\( \\|^\\)\\([^ ]+>>\\)\\( \\|$\\)")
+(defconst fuel-syntax--setter-regex "\\( \\|^\\)\\(>>[^ ]+\\)\\( \\|$\\)")
(defconst fuel-syntax--symbol-definition-regex
(fuel-syntax--second-word-regex '("SYMBOL:" "VAR:")))
From 2156b7bb868cacc50832ec1b42a7e1a4e02e5ee0 Mon Sep 17 00:00:00 2001
From: "Jose A. Ortega Ruiz" <jao@gnu.org>
Date: Thu, 18 Dec 2008 15:38:40 +0100
Subject: [PATCH 05/15] FUEL: Description for vocabularies in autodoc mode.
---
extra/fuel/fuel.factor | 14 ++++++++++----
misc/fuel/fuel-help.el | 15 ++++++++++-----
2 files changed, 20 insertions(+), 9 deletions(-)
diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor
index dacf57cc7f..017b20b54b 100644
--- a/extra/fuel/fuel.factor
+++ b/extra/fuel/fuel.factor
@@ -6,8 +6,8 @@ combinators compiler.units continuations debugger definitions
eval help io io.files io.pathnames io.streams.string kernel
lexer listener listener.private make math memoize namespaces
parser prettyprint prettyprint.config quotations sequences sets
-sorting source-files strings tools.vocabs vectors vocabs
-vocabs.loader ;
+sorting source-files strings summary tools.vocabs vectors
+vocabs vocabs.loader ;
IN: fuel
@@ -160,6 +160,8 @@ M: source-file fuel-pprint path>> fuel-pprint ;
: fuel-end-eval ( -- ) [ ] (fuel-end-eval) ; inline
+: fuel-run-file ( path -- ) run-file ; inline
+
! Edit locations
: fuel-get-edit-location ( defspec -- )
@@ -173,7 +175,7 @@ M: source-file fuel-pprint path>> fuel-pprint ;
! Completion support
: fuel-filter-prefix ( seq prefix -- seq )
- [ drop-prefix nip length 0 = ] curry filter ; inline
+ [ drop-prefix nip length 0 = ] curry filter prune ; inline
: (fuel-get-vocabs) ( -- seq )
all-vocabs-seq [ vocab-name ] map ; inline
@@ -184,6 +186,9 @@ M: source-file fuel-pprint path>> fuel-pprint ;
: fuel-get-vocabs/prefix ( prefix -- )
(fuel-get-vocabs) swap fuel-filter-prefix fuel-eval-set-result ; inline
+: fuel-vocab-summary ( name -- )
+ >vocab-link summary fuel-eval-set-result ; inline
+
MEMO: (fuel-vocab-words) ( name -- seq )
>vocab-link words [ name>> ] map ;
@@ -200,7 +205,8 @@ MEMO: (fuel-vocab-words) ( name -- seq )
: fuel-get-words ( prefix names -- )
(fuel-get-words) fuel-eval-set-result ; inline
-: fuel-run-file ( path -- ) run-file ; inline
+
+! -run=fuel support
: fuel-startup ( -- ) "listener" run-file ; inline
diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el
index e618fd130a..3bfd788702 100644
--- a/misc/fuel/fuel-help.el
+++ b/misc/fuel/fuel-help.el
@@ -76,12 +76,15 @@
(let ((word (or word (fuel-syntax-symbol-at-point)))
(fuel-log--inhibit-p t))
(when word
- (let* ((cmd `(:fuel* (((:quote ,word) synopsis :get)) t))
- (ret (fuel-eval--send/wait cmd 20)))
- (when (and ret (not (fuel-eval--retort-error ret)))
+ (let* ((cmd (if (fuel-syntax--in-using)
+ `(:fuel* (,word fuel-vocab-summary) t t)
+ `(:fuel* (((:quote ,word) synopsis :get)) t)))
+ (ret (fuel-eval--send/wait cmd 20))
+ (res (fuel-eval--retort-result ret)))
+ (when (and ret (not (fuel-eval--retort-error ret)) (stringp res))
(if fuel-help-minibuffer-font-lock
- (fuel-help--font-lock-str (fuel-eval--retort-result ret))
- (fuel-eval--retort-result ret)))))))
+ (fuel-help--font-lock-str res)
+ res))))))
(make-variable-buffer-local
(defvar fuel-autodoc-mode-string " A"
@@ -234,6 +237,8 @@ buffer."
(define-key map "n" 'fuel-help-next)
(define-key map (kbd "SPC") 'scroll-up)
(define-key map (kbd "S-SPC") 'scroll-down)
+ (define-key map "\C-cz" 'run-factor)
+ (define-key map "\C-c\C-z" 'run-factor)
map))
(defconst fuel-help--headlines
From ea71c1fdd24c7f170034368cc1b24c2599c2a342 Mon Sep 17 00:00:00 2001
From: "Jose A. Ortega Ruiz" <jao@gnu.org>
Date: Thu, 18 Dec 2008 17:07:36 +0100
Subject: [PATCH 06/15] FUEL: More navigation keys for the help buffer.
---
misc/fuel/README | 2 ++
misc/fuel/fuel-help.el | 70 +++++++++++++++++++++++++++---------------
2 files changed, 47 insertions(+), 25 deletions(-)
diff --git a/misc/fuel/README b/misc/fuel/README
index cc938a60ff..5073980dbd 100644
--- a/misc/fuel/README
+++ b/misc/fuel/README
@@ -90,5 +90,7 @@ C-cC-eC-r is the same as C-cC-er)).
- RET : help for word at point
- f/b : next/previous page
- SPC/S-SPC : scroll up/down
+ - TAB/S-TAB : next/previous headline
+ - C-cz : switch to listener
- q: bury buffer
diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el
index 3bfd788702..2154cbebd6 100644
--- a/misc/fuel/fuel-help.el
+++ b/misc/fuel/fuel-help.el
@@ -186,6 +186,35 @@ displayed in the minibuffer."
(goto-char (point-min))
(message "%s" def)))
+
+;;; Help mode font lock:
+
+(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)))
+
+
;;; Interactive help commands:
@@ -223,8 +252,18 @@ buffer."
(error "No previous page"))
(fuel-help--insert-contents (car item) (cdr item) t)))
+(defun fuel-help-next-headline (&optional count)
+ (interactive "P")
+ (end-of-line)
+ (when (re-search-forward fuel-help--headlines-regexp nil t (or count 1))
+ (beginning-of-line)))
+
+(defun fuel-help-previous-headline (&optional count)
+ (interactive "P")
+ (re-search-backward fuel-help--headlines-regexp nil t count))
+
-;;;; Factor help mode:
+;;;; Help mode map:
(defvar fuel-help-mode-map
(let ((map (make-sparse-keymap)))
@@ -235,36 +274,17 @@ buffer."
(define-key map "l" 'fuel-help-previous)
(define-key map "p" 'fuel-help-previous)
(define-key map "n" 'fuel-help-next)
+ (define-key map (kbd "TAB") 'fuel-help-next-headline)
+ (define-key map (kbd "S-TAB") 'fuel-help-previous-headline)
+ (define-key map [(backtab)] 'fuel-help-previous-headline)
(define-key map (kbd "SPC") 'scroll-up)
(define-key map (kbd "S-SPC") 'scroll-down)
(define-key map "\C-cz" 'run-factor)
(define-key map "\C-c\C-z" 'run-factor)
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)))
+
+;;; Help mode definition:
(defun fuel-help-mode ()
"Major mode for browsing Factor documentation.
From 670cbbfc9f309e66ecc2a4dc31a2c47813666d3c Mon Sep 17 00:00:00 2001
From: "Jose A. Ortega Ruiz" <jao@gnu.org>
Date: Thu, 18 Dec 2008 17:31:52 +0100
Subject: [PATCH 07/15] FUEL: Nothing new, just function renamings.
---
misc/fuel/fuel-completion.el | 26 +++++++++++++-------------
1 file changed, 13 insertions(+), 13 deletions(-)
diff --git a/misc/fuel/fuel-completion.el b/misc/fuel/fuel-completion.el
index c7340c7037..953a349d2f 100644
--- a/misc/fuel/fuel-completion.el
+++ b/misc/fuel/fuel-completion.el
@@ -59,7 +59,7 @@ performed."))
If this window is no longer active or displaying the completions
buffer then we can ignore `fuel-completion--window-cfg'."))
-(defun fuel-completion--maybe-save-window-configuration ()
+(defun fuel-completion--save-window-cfg ()
"Maybe save the current window configuration.
Return true if the configuration was saved."
(unless (or fuel-completion--window-cfg
@@ -70,17 +70,17 @@ Return true if the configuration was saved."
(defun fuel-completion--delay-restoration ()
(add-hook 'pre-command-hook
- 'fuel-completion--maybe-restore-window-configuration
+ 'fuel-completion--maybe-restore-window-cfg
nil t))
-(defun fuel-completion--forget-window-configuration ()
+(defun fuel-completion--forget-window-cfg ()
(setq fuel-completion--window-cfg nil)
(setq fuel-completion--completions-window nil))
-(defun fuel-completion--restore-window-configuration ()
+(defun fuel-completion--restore-window-cfg ()
"Restore the window config if available."
(remove-hook 'pre-command-hook
- 'fuel-completion--maybe-restore-window-configuration)
+ 'fuel-completion--maybe-restore-window-cfg)
(when (and fuel-completion--window-cfg
(fuel-completion--window-active-p))
(save-excursion
@@ -89,21 +89,21 @@ Return true if the configuration was saved."
(when (buffer-live-p fuel-completion--comp-buffer)
(kill-buffer fuel-completion--comp-buffer))))
-(defun fuel-completion--maybe-restore-window-configuration ()
+(defun fuel-completion--maybe-restore-window-cfg ()
"Restore the window configuration, if the following command
terminates a current completion."
(remove-hook 'pre-command-hook
- 'fuel-completion--maybe-restore-window-configuration)
+ 'fuel-completion--maybe-restore-window-cfg)
(condition-case err
(cond ((find last-command-char "()\"'`,# \r\n:")
- (fuel-completion--restore-window-configuration))
+ (fuel-completion--restore-window-cfg))
((not (fuel-completion--window-active-p))
- (fuel-completion--forget-window-configuration))
+ (fuel-completion--forget-window-cfg))
(t (fuel-completion--delay-restoration)))
(error
;; Because this is called on the pre-command-hook, we mustn't let
;; errors propagate.
- (message "Error in fuel-completion--restore-window-configuration: %S" err))))
+ (message "Error in fuel-completion--restore-window-cfg: %S" err))))
(defun fuel-completion--window-active-p ()
"Is the completion window currently active?"
@@ -112,7 +112,7 @@ terminates a current completion."
fuel-completion--comp-buffer)))
(defun fuel-completion--display-comp-list (completions base)
- (let ((savedp (fuel-completion--maybe-save-window-configuration)))
+ (let ((savedp (fuel-completion--save-window-cfg)))
(with-output-to-temp-buffer fuel-completion--comp-buffer
(display-completion-list completions base)
(let ((offset (- (point) 1 (length base))))
@@ -185,11 +185,11 @@ Perform completion similar to Emacs' complete-symbol."
(partial (cdr result)))
(cond ((null completions)
(fuel--respecting-message "Can't find completion for %S" prefix)
- (fuel-completion--restore-window-configuration))
+ (fuel-completion--restore-window-cfg))
(t (insert-and-inherit (substring partial (length prefix)))
(cond ((= (length completions) 1)
(fuel--respecting-message "Sole completion")
- (fuel-completion--restore-window-configuration))
+ (fuel-completion--restore-window-cfg))
(t (fuel--respecting-message "Complete but not unique")
(fuel-completion--display-or-scroll completions
partial)))))))
From 83f03c89b60337bdc093a435b0383c43d6bef786 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 18 Dec 2008 18:09:22 -0600
Subject: [PATCH 08/15] Fix bogus indentation
---
.../core-foundation/run-loop/run-loop.factor | 30 +++++++++----------
.../core-foundation/strings/.#strings.factor | 1 +
basis/core-foundation/strings/strings.factor | 24 +++++++--------
basis/x11/xim/xim.factor | 12 ++++----
4 files changed, 34 insertions(+), 33 deletions(-)
create mode 120000 basis/core-foundation/strings/.#strings.factor
diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor
index 8b2106685a..4b98e9a410 100644
--- a/basis/core-foundation/run-loop/run-loop.factor
+++ b/basis/core-foundation/run-loop/run-loop.factor
@@ -19,9 +19,9 @@ FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;
FUNCTION: CFRunLoopRef CFRunLoopGetCurrent ( ) ;
FUNCTION: SInt32 CFRunLoopRunInMode (
- CFStringRef mode,
- CFTimeInterval seconds,
- Boolean returnAfterSourceHandled
+ CFStringRef mode,
+ CFTimeInterval seconds,
+ Boolean returnAfterSourceHandled
) ;
FUNCTION: CFRunLoopSourceRef CFFileDescriptorCreateRunLoopSource (
@@ -31,27 +31,27 @@ FUNCTION: CFRunLoopSourceRef CFFileDescriptorCreateRunLoopSource (
) ;
FUNCTION: void CFRunLoopAddSource (
- CFRunLoopRef rl,
- CFRunLoopSourceRef source,
- CFStringRef mode
+ CFRunLoopRef rl,
+ CFRunLoopSourceRef source,
+ CFStringRef mode
) ;
FUNCTION: void CFRunLoopRemoveSource (
- CFRunLoopRef rl,
- CFRunLoopSourceRef source,
- CFStringRef mode
+ CFRunLoopRef rl,
+ CFRunLoopSourceRef source,
+ CFStringRef mode
) ;
FUNCTION: void CFRunLoopAddTimer (
- CFRunLoopRef rl,
- CFRunLoopTimerRef timer,
- CFStringRef mode
+ CFRunLoopRef rl,
+ CFRunLoopTimerRef timer,
+ CFStringRef mode
) ;
FUNCTION: void CFRunLoopRemoveTimer (
- CFRunLoopRef rl,
- CFRunLoopTimerRef timer,
- CFStringRef mode
+ CFRunLoopRef rl,
+ CFRunLoopTimerRef timer,
+ CFStringRef mode
) ;
: CFRunLoopDefaultMode ( -- alien )
diff --git a/basis/core-foundation/strings/.#strings.factor b/basis/core-foundation/strings/.#strings.factor
new file mode 120000
index 0000000000..bbcc303148
--- /dev/null
+++ b/basis/core-foundation/strings/.#strings.factor
@@ -0,0 +1 @@
+slava@slava-pestovs-macbook-pro.local.83429
\ No newline at end of file
diff --git a/basis/core-foundation/strings/strings.factor b/basis/core-foundation/strings/strings.factor
index 2e6180c897..c3a969a325 100644
--- a/basis/core-foundation/strings/strings.factor
+++ b/basis/core-foundation/strings/strings.factor
@@ -23,11 +23,11 @@ TYPEDEF: int CFStringEncoding
: kCFStringEncodingUTF32LE HEX: 1c000100 ;
FUNCTION: CFStringRef CFStringCreateWithBytes (
- CFAllocatorRef alloc,
- UInt8* bytes,
- CFIndex numBytes,
- CFStringEncoding encoding,
- Boolean isExternalRepresentation
+ CFAllocatorRef alloc,
+ UInt8* bytes,
+ CFIndex numBytes,
+ CFStringEncoding encoding,
+ Boolean isExternalRepresentation
) ;
FUNCTION: CFIndex CFStringGetLength ( CFStringRef theString ) ;
@@ -35,16 +35,16 @@ FUNCTION: CFIndex CFStringGetLength ( CFStringRef theString ) ;
FUNCTION: void CFStringGetCharacters ( void* theString, CFIndex start, CFIndex length, void* buffer ) ;
FUNCTION: Boolean CFStringGetCString (
- CFStringRef theString,
- char* buffer,
- CFIndex bufferSize,
- CFStringEncoding encoding
+ CFStringRef theString,
+ char* buffer,
+ CFIndex bufferSize,
+ CFStringEncoding encoding
) ;
FUNCTION: CFStringRef CFStringCreateWithCString (
- CFAllocatorRef alloc,
- char* cStr,
- CFStringEncoding encoding
+ CFAllocatorRef alloc,
+ char* cStr,
+ CFStringEncoding encoding
) ;
: <CFString> ( string -- alien )
diff --git a/basis/x11/xim/xim.factor b/basis/x11/xim/xim.factor
index 862ec3355a..856420af0f 100644
--- a/basis/x11/xim/xim.factor
+++ b/basis/x11/xim/xim.factor
@@ -9,14 +9,14 @@ IN: x11.xim
SYMBOL: xim
: (init-xim) ( classname medifier -- im )
- XSetLocaleModifiers [ "XSetLocaleModifiers() failed" throw ] unless
- [ dpy get f ] dip dup XOpenIM ;
+ XSetLocaleModifiers [ "XSetLocaleModifiers() failed" throw ] unless
+ [ dpy get f ] dip dup XOpenIM ;
: init-xim ( classname -- )
- dup "" (init-xim)
- [ nip ]
- [ "@im=none" (init-xim) [ "XOpenIM() failed" throw ] unless* ] if*
- xim set-global ;
+ dup "" (init-xim)
+ [ nip ]
+ [ "@im=none" (init-xim) [ "XOpenIM() failed" throw ] unless* ] if*
+ xim set-global ;
: close-xim ( -- )
xim get-global XCloseIM drop f xim set-global ;
From cac73daa85bafc6a3f6210cdc50ef5cbacf232e5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 18 Dec 2008 18:09:36 -0600
Subject: [PATCH 09/15] Oops
---
basis/core-foundation/strings/.#strings.factor | 1 -
1 file changed, 1 deletion(-)
delete mode 120000 basis/core-foundation/strings/.#strings.factor
diff --git a/basis/core-foundation/strings/.#strings.factor b/basis/core-foundation/strings/.#strings.factor
deleted file mode 120000
index bbcc303148..0000000000
--- a/basis/core-foundation/strings/.#strings.factor
+++ /dev/null
@@ -1 +0,0 @@
-slava@slava-pestovs-macbook-pro.local.83429
\ No newline at end of file
From 7103cc3cda5ee76279b7e5056a7c27781d4f92b1 Mon Sep 17 00:00:00 2001
From: erg <erg@ubuntubox.(none)>
Date: Thu, 18 Dec 2008 18:32:00 -0600
Subject: [PATCH 10/15] Add follow-link/follow-links, use it in
file-system-info on linux. add docs and unit tests. fix indentation
---
basis/io/files/info/unix/linux/linux.factor | 19 ++++++++----
basis/io/files/info/windows/windows.factor | 5 +---
basis/io/files/links/links-docs.factor | 33 +++++++++++++++++++--
basis/io/files/links/links-tests.factor | 31 +++++++++++++++++++
basis/io/files/links/links.factor | 27 +++++++++++++++--
basis/io/files/links/unix/unix.factor | 2 +-
6 files changed, 103 insertions(+), 14 deletions(-)
create mode 100644 basis/io/files/links/links-tests.factor
diff --git a/basis/io/files/info/unix/linux/linux.factor b/basis/io/files/info/unix/linux/linux.factor
index ee4a1ed91f..69a5597dd4 100644
--- a/basis/io/files/info/unix/linux/linux.factor
+++ b/basis/io/files/info/unix/linux/linux.factor
@@ -3,8 +3,9 @@
USING: accessors alien.c-types alien.syntax combinators csv
io.backend io.encodings.utf8 io.files io.files.info io.streams.string
io.files.unix kernel math.order namespaces sequences sorting
-system unix unix.statfs.linux unix.statvfs.linux
-specialized-arrays.direct.uint arrays io.files.info.unix ;
+system unix unix.statfs.linux unix.statvfs.linux io.files.links.unix
+specialized-arrays.direct.uint arrays io.files.info.unix assocs
+io.pathnames ;
IN: io.files.info.unix.linux
TUPLE: linux-file-system-info < unix-file-system-info
@@ -70,6 +71,16 @@ M: linux file-systems
} cleave
] map ;
+: (find-mount-point) ( path mtab-paths -- mtab-entry )
+ [ follow-links ] dip 2dup at* [
+ 2nip
+ ] [
+ drop [ parent-directory ] dip (find-mount-point)
+ ] if ;
+
+: find-mount-point ( path -- mtab-entry )
+ parse-mtab [ [ mount-point>> ] keep ] H{ } map>assoc (find-mount-point) ;
+
ERROR: file-system-not-found ;
M: linux file-system-info ( path -- )
@@ -80,9 +91,7 @@ M: linux file-system-info ( path -- )
[ file-system-statvfs statvfs>file-system-info ] bi
file-system-calculations
] keep
-
- parse-mtab [ [ mount-point>> ] bi@ <=> invert-comparison ] sort
- [ mount-point>> head? ] with find nip [ file-system-not-found ] unless*
+ find-mount-point
{
[ file-system-name>> >>device-name drop ]
[ mount-point>> >>mount-point drop ]
diff --git a/basis/io/files/info/windows/windows.factor b/basis/io/files/info/windows/windows.factor
index aecf42d9a2..cf826a59d3 100755
--- a/basis/io/files/info/windows/windows.factor
+++ b/basis/io/files/info/windows/windows.factor
@@ -102,10 +102,7 @@ M: windows link-info ( path -- info )
[ GetDiskFreeSpaceEx win32-error=0/f ] 3keep ;
: calculate-file-system-info ( file-system-info -- file-system-info' )
- {
- [ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ]
- [ ]
- } cleave ;
+ [ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ] keep ;
TUPLE: win32-file-system-info < file-system-info max-component flags device-serial ;
diff --git a/basis/io/files/links/links-docs.factor b/basis/io/files/links/links-docs.factor
index 0e9a375da3..4d448e5372 100644
--- a/basis/io/files/links/links-docs.factor
+++ b/basis/io/files/links/links-docs.factor
@@ -1,4 +1,4 @@
-USING: help.markup help.syntax io.files.info ;
+USING: help.markup help.syntax io.files.info math ;
IN: io.files.links
HELP: make-link
@@ -15,9 +15,38 @@ HELP: copy-link
{ make-link read-link copy-link } related-words
+HELP: follow-link
+{ $values
+ { "path" "a pathname string" }
+ { "path'" "a pathname string" }
+}
+{ $description "Returns an absolute path from " { $link read-link } "." } ;
+
+HELP: follow-links
+{ $values
+ { "path" "a pathname string" }
+ { "path'" "a pathname string" }
+}
+{ $description "Follows a chain of symlinks up to " { $link symlink-depth } "." } ;
+
+HELP: symlink-depth
+{ $values
+ { "value" integer }
+}
+{ $description "The number of redirections " { $link follow-links } " will follow." } ;
+
+HELP: too-many-symlinks
+{ $values
+ { "path" "a pathname string" } { "n" integer }
+}
+{ $description "An error thrown when the number of redirections in a chain of symlinks surpasses the value in the " { $link symlink-depth } " variable." } ;
+
ARTICLE: "io.files.links" "Symbolic links"
-"Reading and creating links:"
+"Reading links:"
{ $subsection read-link }
+{ $subsection follow-link }
+{ $subsection follow-links }
+"Creating links:"
{ $subsection make-link }
"Copying links:"
{ $subsection copy-link }
diff --git a/basis/io/files/links/links-tests.factor b/basis/io/files/links/links-tests.factor
new file mode 100644
index 0000000000..55caccb3ae
--- /dev/null
+++ b/basis/io/files/links/links-tests.factor
@@ -0,0 +1,31 @@
+USING: io.directories io.files.links tools.test
+io.files.unique tools.files ;
+IN: io.files.links.tests
+
+: make-test-links ( n path -- )
+ [ '[ [ 1+ ] keep [ number>string _ prepend ] bi@ make-link ] each ]
+ [ [ number>string ] dip prepend touch-file ] 2bi ; inline
+
+[ t ] [
+ [
+ 5 "lol" make-test-links
+ "lol1" follow-links
+ current-directory get "lol5" append-path =
+ ] with-unique-directory
+] unit-test
+
+[
+ [
+ 100 "laf" make-test-links "laf1" follow-links
+ ] with-unique-directory
+] [ too-many-symlinks? ] must-fail-with
+
+[ t ] [
+ 110 symlink-depth [
+ [
+ 100 "laf" make-test-links
+ "laf1" follow-links
+ current-directory get "laf100" append-path =
+ ] with-unique-directory
+ ] with-variable
+] unit-test
diff --git a/basis/io/files/links/links.factor b/basis/io/files/links/links.factor
index 02e1a1b078..8d13de723c 100644
--- a/basis/io/files/links/links.factor
+++ b/basis/io/files/links/links.factor
@@ -1,6 +1,8 @@
! Copyright (C) 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: system kernel vocabs.loader ;
+USING: accessors io.backend io.files.info
+io.files.links.private io.files.types io.pathnames kernel math
+namespaces system unix vocabs.loader ;
IN: io.files.links
HOOK: make-link os ( target symlink -- )
@@ -10,4 +12,25 @@ HOOK: read-link os ( symlink -- path )
: copy-link ( target symlink -- )
[ read-link ] dip make-link ;
-os unix? [ "io.files.links.unix" require ] when
\ No newline at end of file
+os unix? [ "io.files.links.unix" require ] when
+
+: follow-link ( path -- path' )
+ [ parent-directory ] [ read-symbolic-link ] bi append-path ;
+
+SYMBOL: symlink-depth
+10 symlink-depth set-global
+
+ERROR: too-many-symlinks path n ;
+
+<PRIVATE
+
+: (follow-links) ( n path -- path' )
+ over 0 = [ symlink-depth get too-many-symlinks ] when
+ dup link-info type>> +symbolic-link+ =
+ [ [ 1- ] [ follow-link ] bi* (follow-links) ]
+ [ nip ] if ; inline recursive
+
+PRIVATE>
+
+: follow-links ( path -- path' )
+ [ symlink-depth get ] dip normalize-path (follow-links) ;
diff --git a/basis/io/files/links/unix/unix.factor b/basis/io/files/links/unix/unix.factor
index 69b31c6874..2f38c39e02 100644
--- a/basis/io/files/links/unix/unix.factor
+++ b/basis/io/files/links/unix/unix.factor
@@ -7,4 +7,4 @@ M: unix make-link ( path1 path2 -- )
normalize-path symlink io-error ;
M: unix read-link ( path -- path' )
- normalize-path read-symbolic-link ;
+ normalize-path read-symbolic-link ;
From 180aeea68d96aaa1739139ddd0b00c847fe02693 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 18 Dec 2008 18:40:01 -0600
Subject: [PATCH 11/15] fix using. add
---
basis/io/files/links/links.factor | 5 ++---
1 file changed, 2 insertions(+), 3 deletions(-)
diff --git a/basis/io/files/links/links.factor b/basis/io/files/links/links.factor
index 8d13de723c..21cab64a2f 100644
--- a/basis/io/files/links/links.factor
+++ b/basis/io/files/links/links.factor
@@ -1,8 +1,7 @@
! Copyright (C) 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors io.backend io.files.info
-io.files.links.private io.files.types io.pathnames kernel math
-namespaces system unix vocabs.loader ;
+USING: accessors io.backend io.files.info io.files.types
+io.pathnames kernel math namespaces system unix vocabs.loader ;
IN: io.files.links
HOOK: make-link os ( target symlink -- )
From a326943f8bfad933cf2508e5607caf45b47ed3f6 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 18 Dec 2008 18:42:05 -0600
Subject: [PATCH 12/15] better related-words for follow-links. add
---
basis/io/files/links/links-docs.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/io/files/links/links-docs.factor b/basis/io/files/links/links-docs.factor
index 4d448e5372..8419399c92 100644
--- a/basis/io/files/links/links-docs.factor
+++ b/basis/io/files/links/links-docs.factor
@@ -13,8 +13,6 @@ HELP: copy-link
{ $values { "target" "a path to an existing symlink" } { "symlink" "a path to a new symbolic link" } }
{ $description "Copies a symbolic link without following the link." } ;
-{ make-link read-link copy-link } related-words
-
HELP: follow-link
{ $values
{ "path" "a pathname string" }
@@ -29,6 +27,8 @@ HELP: follow-links
}
{ $description "Follows a chain of symlinks up to " { $link symlink-depth } "." } ;
+{ read-link follow-link follow-links } related-words
+
HELP: symlink-depth
{ $values
{ "value" integer }
From 513b4b37084125c522924d3d124907bbd9d223e5 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 18 Dec 2008 19:32:09 -0600
Subject: [PATCH 13/15] use read-link instead, remove dependency on unix. oops
---
basis/io/files/links/links.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/io/files/links/links.factor b/basis/io/files/links/links.factor
index 21cab64a2f..1212d579db 100644
--- a/basis/io/files/links/links.factor
+++ b/basis/io/files/links/links.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors io.backend io.files.info io.files.types
-io.pathnames kernel math namespaces system unix vocabs.loader ;
+io.pathnames kernel math namespaces system vocabs.loader ;
IN: io.files.links
HOOK: make-link os ( target symlink -- )
@@ -14,7 +14,7 @@ HOOK: read-link os ( symlink -- path )
os unix? [ "io.files.links.unix" require ] when
: follow-link ( path -- path' )
- [ parent-directory ] [ read-symbolic-link ] bi append-path ;
+ [ parent-directory ] [ read-link ] bi append-path ;
SYMBOL: symlink-depth
10 symlink-depth set-global
From 4f1aefd3fe23c9a377bf49706780293bcac8fbad Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 18 Dec 2008 19:57:21 -0600
Subject: [PATCH 14/15] fix bootstrap
---
basis/io/files/info/unix/linux/linux.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/io/files/info/unix/linux/linux.factor b/basis/io/files/info/unix/linux/linux.factor
index 69a5597dd4..60313b3306 100644
--- a/basis/io/files/info/unix/linux/linux.factor
+++ b/basis/io/files/info/unix/linux/linux.factor
@@ -3,7 +3,7 @@
USING: accessors alien.c-types alien.syntax combinators csv
io.backend io.encodings.utf8 io.files io.files.info io.streams.string
io.files.unix kernel math.order namespaces sequences sorting
-system unix unix.statfs.linux unix.statvfs.linux io.files.links.unix
+system unix unix.statfs.linux unix.statvfs.linux io.files.links
specialized-arrays.direct.uint arrays io.files.info.unix assocs
io.pathnames ;
IN: io.files.info.unix.linux
From 88ec8786fd50ada80ce22c0876856857f264b3c4 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 18 Dec 2008 20:31:22 -0600
Subject: [PATCH 15/15] add using
---
basis/io/files/links/links-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/io/files/links/links-tests.factor b/basis/io/files/links/links-tests.factor
index 55caccb3ae..2d142ce900 100644
--- a/basis/io/files/links/links-tests.factor
+++ b/basis/io/files/links/links-tests.factor
@@ -1,5 +1,5 @@
USING: io.directories io.files.links tools.test
-io.files.unique tools.files ;
+io.files.unique tools.files fry ;
IN: io.files.links.tests
: make-test-links ( n path -- )