;;;
;;; $Id: emacs-interaction.el,v 1.1 2000/06/18 04:33:09 rlb Exp $
;;;

(require 'cmuscheme)
(require 'advice)
(require 'cl)

(defun guile-process () 
  "Returns the inferior scheme process."
  (get-process "scheme"))

(defvar guile-header-end "^;;;[ ]*end-header"
  "String used to limit the range of the buffer when sending header forms
to the inferior scheme process.  Each form in the buffer preceding this
comment is sent to the scheme process each time a form is evaluated.")

(defvar guile-sending-header-forms-p nil
  "Variable used to track whether already sending header forms and stop
infinite recursion in advice.  Value is t when sending forms, nil otherwise.")

(defun guile-send-header-forms ()
  "Send header forms to the inferior scheme process."
  (interactive)
  (unless guile-sending-header-forms-p
    (let ((guile-sending-header-forms-p t))
      (save-excursion
	(goto-char (point-min))
	(when (re-search-forward guile-header-end 2000)
	  (let ((end (match-beginning 0)))
	    (goto-char (point-min))
	    (forward-list 1)
	    (forward-list -1)
	    (while (< (point) end)
	      (let ((here (point)))
		(scheme-send-definition)
		(goto-char here)
		(forward-list 2)
		(forward-list -1)))))))))

(defadvice scheme-send-definition (before guile-send-definition first nil activate)
  (guile-send-header-forms))

(defadvice scheme-send-region (before guile-send-region first nil activate)
  (guile-send-header-forms))

(defadvice scheme-send-last-sexp (before guile-send-last-sexp first nil activate)
  (guile-send-header-forms))

(defun guile-run-scheme ()
  "Wrapper around run-scheme from cmuscheme.el, that does some
snazzy buffer switching."
  (interactive "")
  (let ((process (guile-process)))
    (if (and process (eq (process-status process) 'run))
      (let ((start-buf (current-buffer)))
	(switch-to-buffer-other-window (process-buffer process))
	(goto-char (point-max))
	(switch-to-buffer-other-window start-buf))
      (let ((start-buf (current-buffer)))
	(run-scheme scheme-program-name)
	(switch-to-buffer start-buf)))))

(defun guile-procedure-documentation ()
  "Get the inferior scheme process to print the doc string of the procedure 
whose name is under point.  This involves first setting the current module."
  (interactive)
  (guile-run-scheme)
  (guile-send-header-forms)
  (save-excursion
    (let ((process (guile-process)))
      (backward-sexp)
      (set-mark (point))
      (forward-sexp 1)
      (let ((str (buffer-substring (point) (mark))))
	(comint-send-string 
	 process 
	 (concat
	  "(begin "
	  "  (newline)"
	  "  (display " str ")"
	  "  (newline)"
	  "  (procedure-documentation " str "))\n"))))))

(defun guile-publicize ()
  "Interactively scan the current buffer, starting at point,
for top level definitions.  For each one found, ask the user
whether to publicize this definition.  For each one assented,
added a 'define-public' statement to the bottom of the source
file."
  (interactive)
  (flet ((find-next-one ()
	   (when (re-search-forward "^(def[-a-zA-Z]*\\ *[\\(]?" nil t)
	     (let ((start (point)))
	       (when (re-search-forward "[\\ \\)]" nil t)
		 (backward-char)
		 (buffer-substring-no-properties start (point)))))))
    (save-excursion
      (let ((public-ls (do ((ret-ls nil)
			    (next-one (find-next-one) (find-next-one)))
			   ((not next-one) ret-ls)
			 (when (y-or-n-p (format "Publicize '%s' " next-one))
			   (push next-one ret-ls)))))
	(goto-char (point-max))
	(insert "\n")
	(mapcar #'(lambda (public)
		    (insert "(define-public " public " " public ")\n"))
		public-ls)))))


;;;
;;;  This page of code is used to make coding new guile primitives easier.
;;;

(defvar guile-type-alist '()
  "An alist that associates guile type names with an alist that describes
the type.  The guile type names are strings so that this variable can be
used as a completion table.  At the moment, there is only one entry in
the alist that describes a type.  The key for that entry is 'pred-fn, and
its value should be a function of one argument that produces a c code fragment
to type check a scheme value.")

(defun guile-new-type (type-name)
  "add a new type to guile-type-alist."
  (if (not (assoc type-name guile-type-alist))
      (setq guile-type-alist (cons (cons type-name '()) guile-type-alist)))
  guile-type-alist)

(defun guile-type-property-set (type-name property val)
  "define an attribute of a type.  the TYPE-NAME should be a string that
has been previously passed to 'guile-new-type'.  PROPERTY should be a symbol.
VAL is an arbitrary elisp value."
  (let ((outer-pair (assoc type-name guile-type-alist)))
    (if (not outer-pair) (error "unknown guile type"))
    (let ((alist (cdr outer-pair)))
      (let ((inner-pair (assq property alist)))
	(if inner-pair
	    (setcdr inner-pair val)
	  (setcdr outer-pair (cons (cons property val) alist)))
	guile-type-alist))))

(defun guile-type-property-ref (type-name property)
  "retrieve an attribute of a type.  the TYPE-NAME should be a string that
has been previously passed to 'guile-new-type'.  PROPERTY should be a symbol."
  (let ((outer-pair (assoc type-name guile-type-alist)))
    (if (not outer-pair) (error "unknown guile type"))
    (let ((alist (cdr outer-pair)))
      (let ((inner-pair (assq property alist)))
	(if inner-pair
	    (cdr inner-pair)
	  (error "unknown guile type property"))))))

(defun guile-insert-primitive (prim-name arg-ls)
  "Insert into the current buffer the skeleton of a new guile primitive.  The
function interactively queries the user for the required information, which is
simply the name of the primitive from the scheme world, and the name and type
of each of the primitive's arguments.  The generated code includes all the
SCM_ASSERT statements required to type check the primitive's arguments.  This
should significantly speed up coding of new guile primitives."
  (interactive
   (let ((prim-name (read-string "primitive name: ")))
     (let ((another-arg-p (y-or-n-p "any args? "))
	   (arg-name nil)
	   (arg-type nil)
	   (ls '()))
       (while another-arg-p
	 (setq arg-name (read-string "arg name: "))
	 (setq arg-type (completing-read "arg type: " guile-type-alist nil t))
	 (setq ls (cons (cons arg-name arg-type) ls))
	 (setq another-arg-p (y-or-n-p "another arg? ")))
       (list prim-name (reverse ls)))))
  (flet ((scheme->c (str)
		    (let ((newstr (copy-sequence str)))
		      (dotimes (i (length str) newstr)
			(if (or (eq ?- (aref str i))
				(eq ?: (aref str i))
				(eq ?! (aref str i))
				(eq ?> (aref str i)))
			    (aset newstr i ?_)))))
	 (c-list (ls)
		 (labels ((iter (ls str)
				(if (null ls) str
				  (iter (cdr ls)
					(concat str (car ls) (if (null (cdr ls)) "" ", "))))))
		   (iter ls "")))
	 (assert-key (n)
		     (format (if (<= n 7) "SCM_ARG%d" "\"wrong type arg in position %d\"") n))
	 (type-check (c-doc-name arg-ls)
		     (let ((str "")
			   (n 1))
		       (while arg-ls
			 (let* ((arg-name (car (car arg-ls)))
				(arg-type (cdr (car arg-ls)))
				(pred-fn (guile-type-property-ref arg-type 'pred-fn)))
			   (setq str (concat str
					     "  SCM_ASSERT("
					     (funcall pred-fn arg-name) ", "
					     arg-name ", "
					     (assert-key n) ", "
					     c-doc-name ");\n"))
			   (setq n (+ 1 n))
			   (setq arg-ls (cdr arg-ls))))
		       str)))
    (let* ((c-prim-name (concat "scm_" (scheme->c prim-name)))
	   (c-doc-name (concat "s_" (scheme->c prim-name)))
	   (n-arg-str (format "%s" (length arg-ls))))
      (insert "\nSCM_PROC(" c-doc-name ", \"" prim-name "\", " n-arg-str ", 0, 0, " c-prim-name ");\n")
      (insert "static SCM\n" c-prim-name "(")
      (insert (c-list (mapcar #'(lambda (arg) (concat "SCM " (car arg))) arg-ls)))
      (insert ")\n")
      (insert "{\n" (type-check c-doc-name arg-ls) "}\n"))))

;;;
;;; initialize with some guile built in types.
;;;
(guile-new-type "inum")
(guile-type-property-set 
 "inum" 'pred-fn 
 (function (lambda (str)
	     (concat "SCM_IMP(" str ") && SCM_INUMP(" str ")"))))
(guile-new-type "double")
(guile-type-property-set
 "double" 'pred-fn
 (function (lambda (str)
	     (concat "scm_inexact_p(" str ") == SCM_BOOL_T"))))
(guile-new-type "rostring")
(guile-type-property-set
 "rostring" 'pred-fn
 (function (lambda (str)
	     (concat "SCM_NIMP(" str ") && SCM_ROSTRINGP(" str ")"))))
(guile-new-type "string")
(guile-type-property-set
 "string" 'pred-fn
 (function (lambda (str)
	     (concat "SCM_NIMP(" str ") && SCM_STRINGP(" str ")"))))
(guile-new-type "char")
(guile-type-property-set
 "char" 'pred-fn
 (function (lambda (str)
	     (concat "SCM_IMP(" str ") && SCM_ICHRP(" str ")"))))

;;;
;;; scheme mode customization
;;;
(setq scheme-program-name "/usr/local/bin/guile")
(defvar menu-bar-my-scheme-menu (make-sparse-keymap "Scheme"))
(define-key menu-bar-my-scheme-menu [my-scheme-run-scheme]
  '("Run Scheme" . guile-run-scheme))

(defun my-scheme-mode-hook ()
  (turn-on-font-lock)
  (define-key scheme-mode-map (read-kbd-macro "C-c d") 'guile-procedure-documentation)
  (define-key scheme-mode-map (read-kbd-macro "C-c x") 'run-scheme)
  (define-key scheme-mode-map (read-kbd-macro "C-c p") 'guile-insert-primitive))
(add-hook 'scheme-mode-hook 'my-scheme-mode-hook)

(provide 'guile-interface)