1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-02 04:40:29 +02:00

*** empty log message ***

This commit is contained in:
Keisuke Nishida 2001-05-02 15:05:05 +00:00
parent abaca96059
commit 7a0d0cee1f
8 changed files with 27 additions and 443 deletions

View file

@ -1,247 +0,0 @@
;;; guile-scheme.el --- Guile Scheme editing mode.
;; Copyright (C) 2001 Keisuke Nishida <kxn30@po.cwru.edu>
;; GNU Emacs 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 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Code:
(require 'scheme)
(defgroup guile-scheme nil
"Editing Guile-Scheme code"
:group 'lisp)
(defvar guile-scheme-syntax-keywords
'((begin 0) (if 1) (cond 0) (case 1) (do 2) (try 1)
quote syntax lambda and or else delay receive
(match 1) (match-lambda 0) (match-lambda* 0)
(let scheme-let-indent) (let* 1) (letrec 1) (and-let* 1)
(let-syntax 1) (letrec-syntax 1) (syntax-rules 1) (syntax-case 2)))
(defvar guile-scheme-special-procedures
'((catch 1) (lazy-catch 1) (stack-catch 1)
map for-each (dynamic-wind 3)))
(dolist (x (append guile-scheme-syntax-keywords
guile-scheme-special-procedures))
(when (consp x)
(put (car x) 'scheme-indent-function (cadr x))))
;; This is shared by cmuscheme and xscheme.
(defcustom guile-scheme-program-name "guile"
"*Program invoked by the `run-scheme' command."
:type 'string
:group 'guile-scheme)
(defconst guile-scheme-font-lock-keywords
(eval-when-compile
(list
(list (concat "(\\(define\\*?\\("
;; Function names.
"\\(\\|-public\\|-method\\|-generic\\)\\|"
;; Macro names, as variable names. A bit dubious, this.
"\\(-syntax\\|-macro\\)\\|"
;; Others
"-\\sw+\\)\\)\\>"
;; Any whitespace and declared object.
"\\s *(?\\(\\sw+\\)?")
'(1 font-lock-keyword-face)
'(5 (cond ((match-beginning 3) font-lock-function-name-face)
((match-beginning 4) font-lock-variable-name-face)
(t font-lock-type-face)) nil t))
(list (concat
"(" (regexp-opt
(mapcar (lambda (e)
(prin1-to-string (if (consp e) (car e) e)))
(append guile-scheme-syntax-keywords
guile-scheme-special-procedures)) 'words))
'(1 font-lock-keyword-face))
'("<\\sw+>" . font-lock-type-face)
'("\\<:\\sw+\\>" . font-lock-builtin-face)
))
"Expressions to highlight in Guile-Scheme modes.")
(defvar guile-scheme-mode-syntax-table nil)
(unless guile-scheme-mode-syntax-table
(let ((i 0))
(setq guile-scheme-mode-syntax-table (make-syntax-table))
(set-syntax-table guile-scheme-mode-syntax-table)
;; Default is atom-constituent.
(while (< i 256)
(modify-syntax-entry i "_ ")
(setq i (1+ i)))
;; Word components.
(setq i ?0)
(while (<= i ?9)
(modify-syntax-entry i "w ")
(setq i (1+ i)))
(setq i ?A)
(while (<= i ?Z)
(modify-syntax-entry i "w ")
(setq i (1+ i)))
(setq i ?a)
(while (<= i ?z)
(modify-syntax-entry i "w ")
(setq i (1+ i)))
;; Whitespace
(modify-syntax-entry ?\t " ")
(modify-syntax-entry ?\n "> ")
(modify-syntax-entry ?\f " ")
(modify-syntax-entry ?\r " ")
(modify-syntax-entry ? " ")
;; These characters are delimiters but otherwise undefined.
;; Brackets and braces balance for editing convenience.
(modify-syntax-entry ?\[ "(] ")
(modify-syntax-entry ?\] ")[ ")
(modify-syntax-entry ?{ "(} ")
(modify-syntax-entry ?} "){ ")
(modify-syntax-entry ?\| " 23")
;; Other atom delimiters
(modify-syntax-entry ?\( "() ")
(modify-syntax-entry ?\) ")( ")
(modify-syntax-entry ?\; "< ")
(modify-syntax-entry ?\" "\" ")
(modify-syntax-entry ?' " p")
(modify-syntax-entry ?` " p")
(modify-syntax-entry ?. " p")
;; Special characters
(modify-syntax-entry ?, "_ p")
(modify-syntax-entry ?# "_ p14")
(modify-syntax-entry ?\\ "\\ ")))
(defvar guile-scheme-mode-line-process "")
(defvar guile-scheme-mode-map nil
"Keymap for Guile Scheme mode.
All commands in `lisp-mode-shared-map' are inherited by this map.")
(unless guile-scheme-mode-map
(let ((map (make-sparse-keymap "Guile-Scheme")))
(setq guile-scheme-mode-map (make-sparse-keymap))
(set-keymap-parent guile-scheme-mode-map lisp-mode-shared-map)
(define-key guile-scheme-mode-map [menu-bar] (make-sparse-keymap))
(define-key guile-scheme-mode-map [menu-bar guile-scheme]
(cons "Guile Scheme" map))
(define-key map [run-guile-scheme]
'("Run Inferior Guile-Scheme" . run-guile-scheme))
(define-key map [uncomment-region]
'("Uncomment Out Region" . (lambda (beg end)
(interactive "r")
(comment-region beg end '(4)))))
(define-key map [comment-region] '("Comment Out Region" . comment-region))
(define-key map [indent-region] '("Indent Region" . indent-region))
(define-key map [indent-line] '("Indent Line" . lisp-indent-line))
(put 'comment-region 'menu-enable 'mark-active)
(put 'uncomment-region 'menu-enable 'mark-active)
(put 'indent-region 'menu-enable 'mark-active)))
(defcustom guile-scheme-mode-hook nil
"Normal hook run when entering `guile-scheme-mode'.
See `run-hooks'."
:type 'hook
:group 'guile-scheme)
;;;
;;; Guile Scheme mode
;;;
;;;###autoload
(defun guile-scheme-mode ()
"Major mode for editing Guile-Scheme code.
Editing commands are similar to those of `lisp-mode'.
In addition, if an inferior Scheme process is running, some additional
commands will be defined, for evaluating expressions and controlling
the interpreter, and the state of the process will be displayed in the
modeline of all Scheme buffers. The names of commands that interact
with the Scheme process start with \"xscheme-\" if you use the MIT
Scheme-specific `xscheme' package; for more information see the
documentation for `xscheme-interaction-mode'. Use \\[run-scheme] to
start an inferior Scheme using the more general `cmuscheme' package.
Commands:
Delete converts tabs to spaces as it moves back.
Blank lines separate paragraphs. Semicolons start comments.
\\{scheme-mode-map}
Entry to this mode calls the value of `scheme-mode-hook'
if that value is non-nil."
(interactive)
(kill-all-local-variables)
(setq mode-name "Guile Scheme")
(setq major-mode 'guile-scheme-mode)
(use-local-map guile-scheme-mode-map)
(guile-scheme-mode-variables)
(run-hooks 'guile-scheme-mode-hook))
(defun guile-scheme-mode-variables ()
(set-syntax-table guile-scheme-mode-syntax-table)
(setq local-abbrev-table scheme-mode-abbrev-table)
(make-local-variable 'paragraph-start)
(setq paragraph-start (concat "$\\|" page-delimiter))
(make-local-variable 'paragraph-separate)
(setq paragraph-separate paragraph-start)
(make-local-variable 'paragraph-ignore-fill-prefix)
(setq paragraph-ignore-fill-prefix t)
(make-local-variable 'fill-paragraph-function)
(setq fill-paragraph-function 'lisp-fill-paragraph)
;; Adaptive fill mode gets in the way of auto-fill,
;; and should make no difference for explicit fill
;; because lisp-fill-paragraph should do the job.
(make-local-variable 'adaptive-fill-mode)
(setq adaptive-fill-mode nil)
(make-local-variable 'normal-auto-fill-function)
(setq normal-auto-fill-function 'lisp-mode-auto-fill)
(make-local-variable 'indent-line-function)
(setq indent-line-function 'lisp-indent-line)
(make-local-variable 'parse-sexp-ignore-comments)
(setq parse-sexp-ignore-comments t)
(make-local-variable 'outline-regexp)
(setq outline-regexp ";;; \\|(....")
(make-local-variable 'comment-start)
(setq comment-start ";")
(make-local-variable 'comment-start-skip)
;; Look within the line for a ; following an even number of backslashes
;; after either a non-backslash or the line beginning.
(setq comment-start-skip "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+[ \t]*")
(make-local-variable 'comment-column)
(setq comment-column 40)
(make-local-variable 'comment-indent-function)
(setq comment-indent-function 'lisp-comment-indent)
(make-local-variable 'parse-sexp-ignore-comments)
(setq parse-sexp-ignore-comments t)
(make-local-variable 'lisp-indent-function)
(set lisp-indent-function 'scheme-indent-function)
(setq mode-line-process '("" guile-scheme-mode-line-process))
(set (make-local-variable 'imenu-case-fold-search) t)
(set (make-local-variable 'imenu-syntax-alist)
'(("+-*/.<>=?!$%_&~^:" . "w")))
(make-local-variable 'font-lock-defaults)
(setq font-lock-defaults
'((guile-scheme-font-lock-keywords)
nil t (("+-*/.<>=!?$%_&~^:@" . "w")) beginning-of-defun
(font-lock-mark-block-function . mark-defun))))
(provide 'guile-scheme)
;;; guile-scheme.el ends here

View file

@ -1,110 +0,0 @@
;;; guile.el --- Emacs Guile interface
;; Copyright (C) 2001 Keisuke Nishida <kxn30@po.cwru.edu>
;; GNU Emacs 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 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Code:
(defun guile:make-adapter (command)
(let* ((buff (generate-new-buffer " *guile object channel*"))
(proc (start-process "guile-oa" buff command "-q")))
(process-kill-without-query proc)
(process-send-string proc "(use-modules (guile channel))\n")
(process-send-string proc "(open-object-channel)\n")
(accept-process-output proc)
proc))
(defun guile:eval (exp adapter)
(let ((str (format "eval %S\n" exp)))
(guile-process-require adapter str "channel> " 'guile:eval-filter)))
(defun guile:eval-filter (proc)
(cond
((looking-at "value = ")
(car (read-from-string (buffer-substring (match-end 0) (point-max)))))
((looking-at "token = ")
(caar (read-from-string (buffer-substring (match-end 0) (point-max)))))
((looking-at "exception = ")
(apply 'signal (car (read-from-string
(buffer-substring (match-end 0) (point-max))))))
(t
(error "Unsupported result"))))
;;;
;;; Process handling
;;;
(defvar guile-process-output-start nil)
(defvar guile-process-output-value nil)
(defvar guile-process-output-filter nil)
(defvar guile-process-output-finished nil)
(defvar guile-process-output-separator nil)
(defvar guile-process-output-separator-lines 2)
(defun guile-process-require (process string separator &optional filter)
(setq guile-process-output-value nil)
(setq guile-process-output-filter filter)
(setq guile-process-output-finished nil)
(setq guile-process-output-separator separator)
(let (temp-buffer)
(unless (process-buffer process)
(setq temp-buffer (guile-temp-buffer))
(set-process-buffer process temp-buffer))
(with-current-buffer (process-buffer process)
(goto-char (point-max))
(insert string)
(setq guile-process-output-start (point))
(set-process-filter process 'guile-process-filter)
(process-send-string process string)
(while (not guile-process-output-finished)
(unless (accept-process-output process 5)
(when (> (point) guile-process-output-start)
(display-buffer (current-buffer))
(error "BUG in the filter!!")))))
(when temp-buffer
(set-process-buffer process nil)
(kill-buffer temp-buffer)))
guile-process-output-value)
(defun guile-process-filter (process string)
(with-current-buffer (process-buffer process)
(insert string)
(forward-line (- guile-process-output-separator-lines))
(if (< (point) guile-process-output-start)
(goto-char guile-process-output-start))
(when (re-search-forward guile-process-output-separator nil 0)
(goto-char (match-beginning 0))
(if guile-process-output-filter
(save-current-buffer
(narrow-to-region guile-process-output-start (point))
(goto-char (point-min))
(setq guile-process-output-value
(funcall guile-process-output-filter process))
(widen))
(setq guile-process-output-value
(buffer-substring guile-process-output-start (point))))
(setq guile-process-output-finished t))))
(defun guile-process-kill (process)
(set-process-filter process nil)
(delete-process process)
(if (process-buffer process)
(kill-buffer (process-buffer process))))
(provide 'guile)
;;; guile.el ends here

View file

@ -1,79 +0,0 @@
;;; Guile object channel
;; Copyright (C) 2001 Free Software Foundation, Inc.
;; 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 2, 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
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Code:
(define-module (guile channel)
:use-syntax (system base syntax)
:export (open-object-channel))
(define-record (<channel> (stdin (current-input-port))
(stdout (current-output-port))
(token-module (make-module))))
(define (make-channel) (<channel>))
(define (native-type? x)
(or (boolean? x) (integer? x) (null? x) (symbol? x) (string? x)
(pair? x) (vector? x)))
(define (open-object-channel)
(let ((ch (make-channel)))
(let loop ()
(catch #t
(lambda ()
(channel:prompt ch)
(let ((cmd (read ch.stdin)))
(if (eof-object? cmd)
(throw 'quit)
(case cmd
((eval)
(module-use! (current-module) ch.token-module)
(let ((val (eval (read ch.stdin) (current-module))))
(if (native-type? val)
(format ch.stdout "value = ~S\n" val)
(let* ((token (gensym "%object-token%"))
(pair (cons token (object->string val))))
(format ch.stdout "token = ~S\n" pair)
(module-define! ch.token-module token val)))))
((destroy)
(let ((token (read ch.stdin)))
(if (module-defined? ch.token-module token)
(module-remove! ch.token-module token)
(channel:error ch "Invalid token: ~S" token))))
((quit)
(throw 'quit))
(else
(channel:error ch "Unknown command: ~S" cmd)))))
(loop))
(lambda args
(case (car args)
((quit) (throw 'quit))
(else
(format ch.stdout "exception = ~S\n" args)
(loop))))))))
(define (channel:prompt ch)
(display "channel> " ch.stdout)
(force-output ch.stdout))
(define (channel:error ch msg . args)
(display "ERROR: " ch.stdout)
(apply format ch.stdout msg args)
(newline ch.stdout))

View file

@ -89,6 +89,9 @@
(let ((m (string-match "\\.[^.]*$" file)))
(string-append (if m (match:prefix m) file) ".go")))
(define-public (scheme-eval x e)
(vm-load (the-vm) (compile-in x e scheme)))
;;;
;;; Scheme compiler interface

View file

@ -395,6 +395,15 @@ SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
}
#undef FUNC_NAME
SCM_DEFINE (scm_vm_break_hook, "vm-break-hook", 1, 0, 0,
(SCM vm),
"")
#define FUNC_NAME s_scm_vm_break_hook
{
VM_DEFINE_HOOK (SCM_VM_BREAK_HOOK);
}
#undef FUNC_NAME
SCM_DEFINE (scm_vm_enter_hook, "vm-enter-hook", 1, 0, 0,
(SCM vm),
"")

View file

@ -4,12 +4,12 @@
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, 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
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
@ -48,11 +48,12 @@
#define SCM_VM_BOOT_HOOK 0
#define SCM_VM_HALT_HOOK 1
#define SCM_VM_NEXT_HOOK 2
#define SCM_VM_ENTER_HOOK 3
#define SCM_VM_APPLY_HOOK 4
#define SCM_VM_EXIT_HOOK 5
#define SCM_VM_RETURN_HOOK 6
#define SCM_VM_NUM_HOOKS 7
#define SCM_VM_BREAK_HOOK 3
#define SCM_VM_ENTER_HOOK 4
#define SCM_VM_APPLY_HOOK 5
#define SCM_VM_EXIT_HOOK 6
#define SCM_VM_RETURN_HOOK 7
#define SCM_VM_NUM_HOOKS 8
struct scm_vm {
scm_byte_t *ip; /* instruction pointer */

View file

@ -183,6 +183,7 @@
#define BOOT_HOOK() RUN_HOOK (SCM_VM_BOOT_HOOK)
#define HALT_HOOK() RUN_HOOK (SCM_VM_HALT_HOOK)
#define NEXT_HOOK() RUN_HOOK (SCM_VM_NEXT_HOOK)
#define BREAK_HOOK() RUN_HOOK (SCM_VM_BREAK_HOOK)
#define ENTER_HOOK() RUN_HOOK (SCM_VM_ENTER_HOOK)
#define APPLY_HOOK() RUN_HOOK (SCM_VM_APPLY_HOOK)
#define EXIT_HOOK() RUN_HOOK (SCM_VM_EXIT_HOOK)

View file

@ -63,6 +63,12 @@ VM_DEFINE_INSTRUCTION (halt, "halt", 0, 0, 0)
return ret;
}
VM_DEFINE_INSTRUCTION (break, "break", 0, 0, 0)
{
BREAK_HOOK ();
NEXT;
}
VM_DEFINE_INSTRUCTION (drop, "drop", 0, 0, 0)
{
DROP ();