From 7a0d0cee1f3f830f7b356457c39e3768f7d24d57 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Wed, 2 May 2001 15:05:05 +0000 Subject: [PATCH] *** empty log message *** --- emacs/guile-scheme.el | 247 --------------------------------- emacs/guile.el | 110 --------------- module/guile/channel.scm | 79 ----------- module/system/base/compile.scm | 3 + src/vm.c | 9 ++ src/vm.h | 15 +- src/vm_engine.h | 1 + src/vm_system.c | 6 + 8 files changed, 27 insertions(+), 443 deletions(-) delete mode 100644 emacs/guile-scheme.el delete mode 100644 emacs/guile.el delete mode 100644 module/guile/channel.scm diff --git a/emacs/guile-scheme.el b/emacs/guile-scheme.el deleted file mode 100644 index 5f8193d71..000000000 --- a/emacs/guile-scheme.el +++ /dev/null @@ -1,247 +0,0 @@ -;;; guile-scheme.el --- Guile Scheme editing mode. - -;; Copyright (C) 2001 Keisuke Nishida - -;; 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 diff --git a/emacs/guile.el b/emacs/guile.el deleted file mode 100644 index 1606feb5c..000000000 --- a/emacs/guile.el +++ /dev/null @@ -1,110 +0,0 @@ -;;; guile.el --- Emacs Guile interface - -;; Copyright (C) 2001 Keisuke Nishida - -;; 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 diff --git a/module/guile/channel.scm b/module/guile/channel.scm deleted file mode 100644 index 0ca7522a6..000000000 --- a/module/guile/channel.scm +++ /dev/null @@ -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 ( (stdin (current-input-port)) - (stdout (current-output-port)) - (token-module (make-module)))) - -(define (make-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)) diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index 3da36a7d1..e6b2d1310 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -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 diff --git a/src/vm.c b/src/vm.c index 50ec84a14..01fafeb6a 100644 --- a/src/vm.c +++ b/src/vm.c @@ -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), "") diff --git a/src/vm.h b/src/vm.h index ecabc4ea6..917c553b6 100644 --- a/src/vm.h +++ b/src/vm.h @@ -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 */ diff --git a/src/vm_engine.h b/src/vm_engine.h index 095fb4217..c4ce6b40f 100644 --- a/src/vm_engine.h +++ b/src/vm_engine.h @@ -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) diff --git a/src/vm_system.c b/src/vm_system.c index 70df6fa64..894c74643 100644 --- a/src/vm_system.c +++ b/src/vm_system.c @@ -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 ();