[Top][All Lists]

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Chicken-users] Re: texinfo

From: Linh Dang
Subject: [Chicken-users] Re: texinfo
Date: Fri, 07 May 2004 22:04:18 -0400
User-agent: Gnus/5.1006 (Gnus v5.10.6) Emacs/21.3 (gnu/linux)

On 7 May 2004, address@hidden wrote:

> Linh Dang wrote:
>> On 5 May 2004, address@hidden wrote:
>>> BTW, the hen.el works quite good. But apropos doesn't work, and
>>> I'm not sure why. I've attached a slightly changed version,
>>> that also doesn't depend on the lolevel unit.
>> I've tried your changes but it doesn't seem to work with 1.43
>> (segmentation fault). does your change need 1.46?
> Hm. Strange. But getting the newest version of Chicken might be ok.

I think I narrowed it down. You use ##csi#name-of-symbols-matching
instead of ##csi#symbols-matching. I fixed that and your version of
apropos now works correctly.


----- hen.el -----
;;; HEN.EL ---  mode for editing chicken code

;; Copyright (C) 2004 Linh Dang

;; Author: Linh Dang <linhd@>
;; Maintainer: Linh Dang <linhd@>
;; Created: 19 Apr 2004
;; Version: 1
;; Keywords:

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.

;; A copy of the GNU General Public License can be obtained from this
;; program's author (send electronic mail to <linhd@>) or from the
;; Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139,
;; USA.

;; LCD Archive Entry:
;; hen|Linh Dang|<linhd@>
;; | mode for editing chicken code
;; |$Date: 2004/05/08 02:01:12 $|$Revision: 1.20 $|~/packages/hen.el

;;; Commentary:
;; Hen is a mode derived from scheme-mode and is specialized for
;; editing chicken scheme.
;; This mode assumes:
;;     - the user has install
;;     - the csi executable can be launch as "csi"
;;     - the #csi##oblist and co are available from oblist library

;;; Change log:
;; $Log: hen.el,v $
;; Revision 1.20  2004/05/08 02:01:12  linhd
;; use felix version
;; Revision 1.19  2004/05/03 14:43:37  linhd
;; huh
;; Revision 1.18  2004/04/29 17:45:03  linhd
;; cool
;; Revision 1.17  2004/04/29 17:29:07  linhd
;; ok
;; Revision 1.16  2004/04/23 15:33:49  linhd
;; minor
;; Revision 1.15  2004/04/23 15:33:26  linhd
;; add doc
;; Revision 1.14  2004/04/23 15:31:24  linhd
;; almost complete
;; Revision 1.13  2004/04/23 15:29:04  linhd
;; cool
;; Revision 1.12  2004/04/23 15:01:55  linhd
;; cool
;; Revision 1.11  2004/04/23 13:29:44  linhd
;; before changing to new strategy
;; Revision 1.10  2004/04/22 12:37:50  linhd
;; cool
;; Revision 1.9  2004/04/21 18:42:08  linhd
;; cool
;; Revision 1.8  2004/04/20 14:35:12  linhd
;; huh
;; Revision 1.7  2004/04/20 14:33:36  linhd
;; add info lookup
;; Revision 1.6  2004/04/19 16:30:14  linhd
;; cleanup
;; Revision 1.5  2004/04/19 16:28:21  linhd
;; cool
;; inferior csi works
;; Revision 1.4  2004/04/19 15:47:43  linhd
;; remove <...> symbols
;; Revision 1.3  2004/04/19 15:29:48  linhd
;; huh
;; Revision 1.2  2004/04/19 14:59:26  linhd
;; cool
;; Revision 1.1  2004/04/19 14:52:48  linhd
;; Initial revision

;;; Code:

(defconst hen-version (substring "$Revision: 1.20 $" 11 -2)
  "$Id: hen.el,v 1.20 2004/05/08 02:01:12 linhd Exp $

Report bugs to: Linh Dang <linhd@>")
(defvar hen-load-hook nil
  "*Hooks run after loading hen.")

(require 'scheme)
(require 'info-look)
(require 'compile)

(defconst hen-syntax-table
  (let ((tab (copy-syntax-table scheme-mode-syntax-table)))
    (modify-syntax-entry ?# "_   " tab)
    (modify-syntax-entry ?: "_   " tab)
    (modify-syntax-entry ?\[ "(]  " tab)
    (modify-syntax-entry ?\] ")[  " tab)


(defconst hen-font-lock-keywords-1
     ;; Declarations
     (list (concat "\\(?:(\\|\\[\\)"
                      "define-values") 1)

           '(1 font-lock-keyword-face)
           '(2 font-lock-function-name-face nil t))))
  "Basic font-locking for Hen mode.")

(defconst hen-font-lock-keywords-2
  (append hen-font-lock-keywords-1
      ;; Control structures.
        "(" (regexp-opt
             '("begin" "begin0" "begin-form"
               "call-with-current-continuation" "call/cc"
               "call-with-input-pipe" "call-with-output-pipe"
               "call-with-input-file" "call-with-output-file"
               "call-with-input-string" "call-with-output-string"

               "case" "case-lambda" "cond" "cond-expand" "condition-case" 

               "do" "else" "for-each" "if" "lambda" "when" "while" "if*" 

               "let" "let*" "let-syntax" "letrec" "letrec-syntax"
               "and-let*" "let-optionals" "let-optionals*" "let-macro"
               "fluid-let" "let-values" "let*-values" "letrec-values"

               "and" "or" "delay" "andmap" "ormap"

               "assert" "ignore-errors" "critical-section" "ensure" "eval-when"

               "with-input-from-file" "with-output-to-file"
               "with-input-from-pipe" "with-output-to-pipe"
               "with-input-from-string" "with-output-to-string"

               "map" "syntax" "syntax-rules") t)
        "\\>") 1)
      ;;  `:' keywords as builtins.
      '("quasi\\(?:quote\\)?" . font-lock-builtin-face)
      '("#?\\<:\\sw+\\>" . font-lock-builtin-face)
      '(",@?\\|`" . font-lock-builtin-face)
      '("\\(##\\sw+#\\)" (1 font-lock-builtin-face t nil))
      '("#\\\\?\\sw+"  (0 font-lock-constant-face nil t))
      '("(\\(declare\\|require\\)" . font-lock-keyword-face)
  "Gaudy expressions to highlight in Hen mode.")

(defconst hen-font-lock-keywords hen-font-lock-keywords-2)

(mapc (lambda (cell)
        (put (car cell) 'scheme-indent-function (cdr cell)))
      '((begin0 . 0) (begin-form . 0)

        (for-each . 1) (when . 1) (while . 1) (unless . 1)
        (and-let* . 1) (fluid-let . 1)

        (call-with-input-pipe . 1)
        (call-with-ouput-pipe . 1)
        (call-with-input-string . 1)
        (call-with-input-string . 1)

        (call-with-values . 1)

        (with-input-from-pipe . 1)
        (with-ouput-to-pipe . 0)
        (with-input-from-string . 1)
        (with-output-to-string . 0)

        (if* . 2)))

(defun hen-identifier-at-point ()
  "Return the identifier close to the cursor."
      (let ((beg (line-beginning-position))
            (end (line-end-position))
            (pos (point)))
      (cond ((progn (goto-char pos)
                    (skip-chars-forward " \t" end)
                    (skip-syntax-backward "w_" beg)
                    (memq (char-syntax (following-char)) '(?w ?_)))
             (buffer-substring-no-properties (point) (progn (forward-sexp 1) 
            ((progn (goto-char pos)
                    (skip-chars-backward " \t" beg)
                    (skip-syntax-forward "w_" end)
                    (memq (char-syntax (preceding-char)) '(?w ?_)))
             (buffer-substring-no-properties (point) (progn (forward-sexp -1) 
            (t nil))))))

(defun hen-build (cmd args)
  (compile-internal (mapconcat 'identity (cons cmd args) " ")
                    "No more errors" "csc" nil
                    `(("Error:.+in line \\([0-9]+\\):" 0 1 nil 
                    (lambda (ignored) "*csc*")))

(defun hen-build-unit ()
  (let* ((file-name (file-name-nondirectory
         (base-name (file-name-sans-extension file-name)))
    (hen-build "csc" (list "-s" file-name "-o" (concat base-name ".so")) )))

(defun hen-build-program ()
  (let* ((file-name (file-name-nondirectory
         (base-name (file-name-sans-extension file-name)))
    (hen-build "csc" (list file-name) )))

(define-derived-mode hen-mode scheme-mode "Hen"
  "Mode for editing chicken Scheme code.
\\[hen-complete-symbol] completes symbol base on the text at point.
\\[hen-csi-eval-last-sexp] evaluates the sexp at/preceding point in csi.
\\[hen-csi-eval-region] evaluates the region in csi.
\\[hen-csi-apropos] lists the csi's symbols matching a regex.
\\[hen-csi-send] reads a s-exp from the user and evaluates it csi.
\\[hen-describe-symbol] looks up info documentation for a symbol from.
the R5RS and Chicken info files.
\\[hen-build-unit] compiles the current file as a shared object
\\[hen-describe-symbol] compiles the current file as a program

  (set-syntax-table hen-syntax-table)
  (setq local-abbrev-table scheme-mode-abbrev-table)

  (define-key hen-mode-map (kbd "M-TAB")   'hen-complete-symbol)
  (define-key hen-mode-map (kbd "C-c C-e") 'hen-csi-eval-last-sexp)
  (define-key hen-mode-map (kbd "C-c C-r") 'hen-csi-eval-region)
  (define-key hen-mode-map (kbd "C-c C-a") 'hen-csi-apropos)
  (define-key hen-mode-map (kbd "C-c C-h") 'hen-describe-symbol)
  (define-key hen-mode-map (kbd "C-c C-l") 'hen-build-unit)
  (define-key hen-mode-map (kbd "C-c C-x") 'hen-csi-send)
  (define-key hen-mode-map (kbd "C-c C-l") 'hen-build-unit)
  (define-key hen-mode-map (kbd "C-c C-c") 'hen-build-program)

  (define-key hen-mode-map [menu-bar scheme run-scheme] nil)
  (define-key hen-mode-map [menu-bar shared build-prog] '("Compile File" 
  (define-key hen-mode-map [menu-bar shared send-to-csi] '("Evaluate" . 
  (define-key hen-mode-map [menu-bar scheme build-as-unit] '("Compile File as 
Unit" . hen-build-unit))
  (define-key hen-mode-map [menu-bar scheme describe-sym] '("Lookup 
Documentation for Symbol" . hen-describe-symbol))
  (define-key hen-mode-map [menu-bar scheme apropos] '("Symbol Apropos" . 
  (define-key hen-mode-map [menu-bar scheme eval-region] '("Eval Region" . 
  (define-key hen-mode-map [menu-bar scheme eval-last-sexp] '("Eval Last 
S-Expression" . hen-csi-eval-last-sexp))

  (setq font-lock-defaults
           hen-font-lock-keywords-1 hen-font-lock-keywords-2)
          nil t (("+-*/.<>=!?$%_&~^:" . "w")) beginning-of-defun
          (font-lock-mark-block-function . mark-defun))))

;;stolen from cxref
(defun hen-looking-backward-at (regexp)
  "Return t if text before point matches regular expression REGEXP.
This function modifies the match data that `match-beginning',
`match-end' and `match-data' access; save and restore the match
data if you want to preserve them."
    (let ((here (point)))
      (if (re-search-backward regexp (point-min) t)
          (if (re-search-forward regexp here t)
              (= (point) here))))))

(defun hen-proc-wait-prompt (proc prompt-re &optional timeout msg)
  "Wait for the prompt of interactive process PROC. PROMPT-RE must be
a regexp matching the prompt. TIMEOUT is the amount of time to wait in
secs before giving up. MSG is the message to display while waiting."
  (setq timeout (if (numberp timeout) (* timeout 2) 60))
  (unless (stringp msg)
    (setq msg (concat "wait for "
                      (process-name proc)
                      "'s prompt")))
  (goto-char (process-mark proc))
  (accept-process-output proc 0 100000)
  (if (hen-looking-backward-at prompt-re)
    (while (and (> timeout 0) (not (hen-looking-backward-at prompt-re)))
      (with-temp-message (setq msg (concat msg "."))
        (accept-process-output proc 0 500000))
      (setq timeout (1- timeout))
      (goto-char (process-mark proc)))
    (with-temp-message (concat msg (if (> timeout 0)
                                       " got it!" " timeout!"))
      (sit-for 0 100))
    (> timeout 0)))

(defun hen-proc-send (question proc prompt-re &optional timeout msg)
  "Send the string QUESTION to interactive process proc. PROMPT-RE is
the regexp matching PROC's prompt. TIMEOUT is the amount of time to
wait in secs before giving up. MSG is the message to display while
  (setq timeout (if (numberp timeout) (* timeout 2) 60))
    (set-buffer (process-buffer proc))
      (when (hen-proc-wait-prompt proc prompt-re (/ timeout 2))
        (let ((start (match-end 0)))
          (narrow-to-region start (point-max))
          (process-send-string proc (concat question "\n"))
          (accept-process-output proc 0 500000)
          (hen-proc-wait-prompt proc prompt-re timeout msg)
          (narrow-to-region start (match-beginning 0))

(defun hen-csi-buffer () (get-buffer-create " *csi*"))

(defun hen-csi-proc ()
  (let ((proc (get-buffer-process (hen-csi-buffer))))
    (if (and (processp proc)
             (eq (process-status proc) 'run))
      (setq proc (start-process "csi" (hen-csi-buffer) "csi"))
      (with-current-buffer (hen-csi-buffer)
        (accept-process-output proc)
        (hen-proc-wait-prompt proc "#;> ")
        (hen-proc-send "(require 'oblist)" proc "#;> ")

(defun hen-csi-send (sexp)
  "Evaluate SEXP in CSI"
   (let ((sexp (read-string "Evaluate S-expression: "))
         (send-sexp-p nil))
           (let ((obarray (make-vector 11 0)))
             (read sexp)
             (setq send-sexp-p t)))
       (unless send-sexp-p
         (setq send-sexp-p
               (y-or-n-p (format "`%s' is not a valid sexp! evaluate anyway? " 
     (list (if send-sexp-p sexp nil))))
  (when (stringp sexp)
    (let* ((proc (hen-csi-proc))
           (buf (hen-proc-send (concat sexp "\n") proc "#;> "))
           result len)
      (unless (buffer-live-p buf)
        (error "Internal hen-mode failure"))

        (with-current-buffer buf
          (setq result (buffer-string))
          (setq len (length result))
          (if (and (> len 0)
                   (eq (aref result (1- len)) ?\n))
              (setq result (substring result 0 -1)))

(defun hen-csi-eval-region (beg end)
  "Evaluate the current region in CSI."
  (interactive "r")
   (hen-csi-send (buffer-substring beg end))))

(defun hen-csi-eval-last-sexp ()
  "Evaluate the s-expression at point in CSI"
   (hen-csi-eval-region (save-excursion (backward-sexp) (point))

(defun hen-csi-eval-definition ()
  "Evaluate the enclosing top-level form in CSI."
     (hen-csi-eval-region (progn (beginning-of-defun) (point))
                          (progn (forward-sexp 1) (point))))))

(defun hen-complete-symbol (thing)
  "Complete symbol at point in Hen mode. THING is used as the prefix."
  (interactive (list (hen-identifier-at-point)))
  (let* ((matching-names-alist
            (concat "(pp (map list (delete-duplicates 
(##csi#name-of-symbols-starting-with \""
         (completion (try-completion thing matching-names-alist)))
    (cond ((eq completion t) nil)
          ((null completion)
           (error "Can't find completion for \"%s\"" thing))
          ((not (string= thing completion))
           (delete-region (progn (backward-sexp 1) (point))
                          (progn (forward-sexp 1) (point)))
           (insert completion))
           (message "Making completion list...")
           (with-output-to-temp-buffer "*Completions*"
              (all-completions thing matching-names-alist)))))))

(defun hen-csi-try-complete (string ignore1 &optional ignore2)
  (let ((matches
           (concat "(pp (map list (delete-duplicates 
(##csi#name-of-symbols-starting-with \""
    (cond ((null matches) nil)
          ((and (= (length matches) 1)
                (string-equal (caar matches) string))
          (t (try-completion string matches)))))

(defsubst hen-csi-symbol-completing-read (prompt)
  (list (completing-read prompt 'hen-csi-try-complete
                         nil nil (hen-identifier-at-point))))

(defun hen-describe-symbol (name)
  "Lookup documentation for symbol NAME."
  (interactive (hen-csi-symbol-completing-read "Describe symbol: "))
  (info-lookup-symbol name 'hen-mode) ;
  ;;(hen-lookup-info-doc name)

(defun hen-csi-apropos (regex)
  "List the symbols matching REGEX."
  (interactive "sApropos (chicken's global symbols): ")
  (with-current-buffer (get-buffer-create "*Chicken Apropos*")
    (let* ((query (concat "(pp (map\n"
                          "  (lambda (sym) (cons (->string sym)\n"
                          "      (->string (if 
(##sys#symbol-has-toplevel-binding? sym)\n "
                          "                 (##sys#slot sym 0) '<unbound> 
                          "  (delete-duplicates! (##csi#symbols-matching \"" 
regex  "\"))))"))
           (results-alist (read (hen-csi-send query))))
      (if (display-mouse-p)
          (insert "If moving the mouse over text changes the text's color,\n"
                   "you can click \\[apropos-mouse-follow] on that text to get 
more information.\n")))
      (insert "In this buffer, go to the name of the command, or function,"
              " or variable,\n"
               "and type \\[apropos-follow] to get full documentation.\n\n"))

      (dolist (item results-alist)
        (let ((name (car item))
              (obj (cdr item)))
          (insert (car item) " ")
          (add-text-properties (line-beginning-position) (1- (point))
                               `(item ,name action hen-describe-symbol
                                      face bold mouse-face highlight
                                      help-echo "mouse-2: display help on this 
          (indent-to-column 40)
          (insert (cdr item) "\n")))

  (pop-to-buffer "*Chicken Apropos*" t))

(defconst hen-info-doc-list '("(r5rs)Index" "(chicken)Index"))

(defun hen-lookup-info-doc (topic)
  (let ((docs hen-info-doc-list)
        (pattern (format "\n\\* +\\([^\n:]*%s[^\n:]*\\):[ \t]*\\([^.\n]*\\)\\.[ 
        doc node found)
    (while (and (consp docs) (not found))
      (setq doc (car docs)
            docs (cdr docs))
      (setq found (save-window-excursion
                      (Info-goto-node doc)
                      (goto-char (point-min))
                      (re-search-forward pattern nil t)))))
    (if found
          (pop-to-buffer "*info*")
          (hen-lookup-info-doc topic))
      (error "Can't find documentation for %s" topic))))

 :mode 'hen-mode
 :regexp "[^()'\" \t\n]+"
 :ignore-case t
 ;; Aubrey Jaffer's rendition from <URL:>
 :doc-spec '(("(chicken)Index" nil
              "^[ \t]+- [^:\n]+:[ \t]*" "")
             ("(r5rs)Index" nil
              "^[ \t]+- [^:\n]+:[ \t]*" "")))

(provide 'hen)
(run-hooks 'hen-load-hook)
;;; HEN.EL ends here

reply via email to

[Prev in Thread] Current Thread [Next in Thread]