This is the mail archive of the guile@cygnus.com mailing list for the guile project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]

Re: hooking guile to hardware


karlheg@inetarena.com (Karl M. Hegbloom) writes:

> >>>>> "Russ" == Russ McManus <mcmanr@eq.gs.com> writes:
>
>     Russ> In my experience, the quickest way to do something like this
>     Russ> is to expose a 'C-ish' interface to Scheme using hand coded
>     Russ> primitives.  I use some elisp to make this quick and
>     Russ> painless.  What I mean by 'C-ish' is stuff like returning -1
>     Russ> on error, and setting a global var to the error value.
>
>  Will you please post that elisp?  I'd really like to see how you do
>  it.

Ok.  The elisp I use is part of my guile interaction package, which is
not well modularized :-(  You can cut and paste to your heart's
desire.

The motivating idea is that almost all the work of writing a new
primitive is in doing the run time type checking of the supplied
arguments.  (This is really only true if you follow my earlier
suggestion about first exposing a 'C-ish' interface to Scheme, and
then providing a proper Scheme interface on top of that.)

I find it's easier to do as little as possible in 'C' anyway.

The code assumes that you've told Emacs about your new type.  Once
that is done, you use an interactive function to describe the
arguments to your new primitive, and then Emacs inserts the skeleton
of the primitive into the current buffer at point.

Perhaps an example is in order.  Lets say that I define a new Scheme
data type (smob) called a channel.  I have a type testing function
that looks like this:

/* beware code straight from memory */
static int
channel_p(SCM obj)
{
    return(SCM_NIMP(obj) && SCM_CAR(obj) == g.channel_type_tag);
}

Then I let Emacs know about this new type with the following forms:

(guile-new-type "channel")  ;; define a new type
(guile-type-property-set    ;; tell Emacs how to type test this type
 "channel" 'pred-fn 
 (function (lambda (str)
	     (concat "exec_p(" str ")"))))

Now I can do:

  M-x guile-insert-primitive

Which interactively asks me for the name and type of each argument to
the new primitive.  So if I defined a new primitive called "snk-open"
with arguments "channel" of type "channel", "source-name" of type
"string", and "item-name" of type string, Emacs would generate a call
to guile-insert-primitive that looks like this:

    (guile-insert-primitive             
     "snk-open"                         
     (quote (("channel" . "channel")    
             ("source-name" . "string") 
             ("item-name" . "string"))))

The string inserted into the buffer looks like this:

    SCM_PROC(s_snk_open, "snk-open", 3, 0, 0, scm_snk_open);                                             
    static SCM                                                                                           
    scm_snk_open(SCM channel, SCM source-name, SCM item-name)                                            
    {                                                                                                    
      SCM_ASSERT(exec_p(channel), channel, SCM_ARG1, s_snk_open);                                        
      SCM_ASSERT(SCM_NIMP(source-name) && SCM_STRINGP(source-name), source-name, SCM_ARG2, s_snk_open);  
      SCM_ASSERT(SCM_NIMP(item-name) && SCM_STRINGP(item-name), item-name, SCM_ARG3, s_snk_open);        
    }                                                                                                    

I didn't have to remember how to do type tests, or the format to
SCM_ASSERT, or anything else for any of this, which is the whole
idea.

A few interesting thing to point out.  I didn't use th gh_ interface,
for no particularly good reason.  The generated code could just as
easily use gh_.  With one exception (oops), the registration of the
primitive into the interpreter.  With my code, I am using the same
mechanism as is used in the guile source itself, which has the advantage
of keeping the registration physically next to the primitive definition.
If you use the gh_ registration function, there is no obvious way to
know where to insert the registration code.

Enough baloney.  Now for some elisp (it's been posted before, but
I'll post it again):

;;;
;;; $Id: guile-interface.el,v 1.4 1998/08/01 20:47:37 mcmanr Exp mcmanr $
;;;

(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)