xyzzy lisp repl

.xyzzy

(require "ldoc2")
(require "xl-repl")

(add-hook 'repl:*startup-hook*
	  '(lambda ()
	    (pushnew 'ed:lisp-repl-mode *ldoc-activated-mode-list*)))

xl-repl.l

;;; -*- mode:lisp; package:repl -*-

(in-package :editor)
(export '(lisp-repl-mode start-repl))

(defpackage :repl
  (:use :lisp :editor))

(in-package :repl)
(export '(*buffer-name*
	  *keymap*
	  *prompt*
	  *prompt-style*
	  *error-style*
	  *startup-hook*))

(defvar *buffer-name* "*xlrepl*")
(defvar *prompt* "xl-%p>")
(defvar *prompt-style* '(:foreground 12 :bold t))
(defvar *error-style* '(:foreground 1))
(defvar *startup-hook* nil)
(defvar *startup-package* "user")
(defvar *commands* nil)

(defparameter *keymap* nil)
(unless #0=*keymap*
  (setq #0# (make-sparse-keymap))
  (define-key #0# #\RET 'newline-or-eval-input)
  (define-key #0# '(#\C-c #\C-l) 'clear-buffer)
  (define-key #0# #\C-h 'repl-backward-delete-char)
  (define-key #0# #\Delete 'repl-delete-char-or-selection)
  (define-key #0# #\C-d 'repl-delete-char-or-selection)
  (define-key #0# #\C-l 'clear-repl))

(defvar-local *input-history* nil)

(defmacro iflet (var test then else)
  `(let ((,var ,test)) (if ,var ,then ,else)))

(defmacro whenlet (var test &body body)
  `(let ((,var ,test)) (when ,var ,@body)))

(defmacro whilet (var test &body body)
  `(do ((,var ,test ,test)) ((not ,var) nil) ,@body))

(defmacro nth-value (n form)
  `(nth ,n (multiple-value-list ,form)))


(defun format-prompt ()
  (with-output-to-string (os)
    (with-input-from-string (is *prompt*)
      (whilet c (read-char is nil nil)
	(princ
         (if (char= c #\%)
	     (let ((post (read-char is nil nil)))
	       (if (null post) c
		 (case (char-downcase post)
		   (#\p *buffer-package*)
		   (#\d (default-directory))
		   (#\u (user-name))
		   (#\m (machine-name))
		   (#\o (os-platform))
		   (#\v (software-version))
		   (#\n (software-type))
		   (t post))))
	   c) os)))))

(defun show-prompt (&optional default)
  (goto-char (point-max))
  (unless (bolp) (insert "\n") (forward-char))
  (let ((p (point)))
    (insert (format-prompt) #\SPC)
    (apply #'set-text-attribute p (point-max) 'prompt *prompt-style*)
    #0=(goto-char (point-max))
    (when default (insert default))
    #0#))

(defmacro previous-prompt-point ()
  `(find-text-attribute 'prompt :end (point) :from-end t))

(defmacro next-prompt-point ()
  `(find-text-attribute 'prompt :start (point)))

(defun repl-backward-delete-char (&optional (n 1))
  (interactive "p")
  (let ((p (point)))
    (multiple-value-bind (from to) (previous-prompt-point)
      (if (<= from p (1- to))
	  (goto-char to)
	(backward-delete-char-untabify-or-selection (min n (- p to)))))))

(defun repl-delete-char-or-selection (&optional (n 1))
  (interactive "p")
  (let ((p (point)))
    (multiple-value-bind (from to) (previous-prompt-point)
      (unless (<= from p (1- to))
	(delete-char-or-selection n)))))

(defun get-input ()
  (multiple-value-bind (from to) (previous-prompt-point)
    (save-excursion
      (goto-eol)
      (buffer-substring to (point)))))

(defun input-complete-p ()
  (save-excursion
    (let ((from (nth-value 1 (previous-prompt-point))))
      (goto-eol)
      (while (and (>= (point) from)
		  (ignore-errors (backward-sexp)))
	(skip-chars-backward " \t\n"))
      (<= (point) from))))

(defun eval-and-print (input)
  (handler-case
      (let ((*package* (or (find-package *buffer-package*)
			   (find-package "user")))
	    (forms nil))
	(with-input-from-string (is input)
	  (do ((s #0=(read is nil #1='#:eos) #0#))
	      ((eq s #1#))
	    (push s forms)))
	(with-output-to-buffer ((selected-buffer) (point-max))
	  (setq forms (nreverse forms))
	  (iflet com (and (keywordp (car forms)) (getf *commands* (car forms)))
	       (apply com (cdr forms))
	    (dolist (expr (nreverse forms))
	      (let ((results (save-excursion
			       (multiple-value-list (eval expr)))))
		(setq *buffer-package* (package-name *package*))
		(format t "~{~S~^ ;~%~}~%~%" results))))))
    (error (c)
      (let ((start (point-max)))
	(with-output-to-buffer ((selected-buffer) start)
	  (format t "~A~%~%" (si:*condition-string c)))
	(apply #'set-text-attribute start (- (point-max) 2) 'error
	       *error-style*)))))

(defun newline-or-eval-input ()
  (interactive)
  (if (input-complete-p)
      (let ((input (get-input)))
	(if (next-prompt-point)
	    (show-prompt input)
	  (goto-eol))
	(newline)
	(eval-and-print input)
	(show-prompt))
    (lisp-newline-and-indent)))

(defun clear-repl ()
  (interactive)
  (delete-region (point-min) (point-max))
  (show-prompt))


(defun ed::lisp-repl-mode ()
  (interactive)
  (lisp-mode)
  (setq buffer-mode 'ed::lisp-repl-mode
	mode-name "REPL")
  (use-keymap *keymap*)
  (unless (file-visited-p)
    (make-local-variable 'need-not-save)
    (make-local-variable 'auto-save)
    (setq need-not-save t
	  auto-save nil))
  (setq *buffer-package* *startup-package*)
  (run-hooks '*startup-hook*))

(defun ed::start-repl ()
  (interactive)
  (let ((buf (get-buffer-create "*xlrepl*")))
    (set-buffer buf)
    (when (eq buffer-mode 'ed::lisp-repl-mode)
      (return-from ed::start-repl))
    (ed::lisp-repl-mode)
    (insert ";;; xyzzy lisp REPL\n")
    (show-prompt)))