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] |
i found it tedious to constantly code the SCM_PROC's and SCM_ASSERT's
required for a new guile primitive, so i added a c code generator to
guile-interface.el. the code generator queries the user for the
scheme name of the new primitive, and the name and type of each of the
primitive's arguments. the querying for types supports completion.
new smobs are easy to add.
for example this expression (which was generated interactively):
(guile-insert-primitive "new-primitive"
(quote (("foo" . "string") ("foo2" . "double"))))
creates the following code:
SCM_PROC(s_new_primitive, "new-primitive", 2, 0, 0, scm_new_primitive);
static SCM
scm_new_primitive(SCM foo, SCM foo2)
{
SCM_ASSERT(SCM_NIMP(foo) && SCM_STRINGP(foo), foo, SCM_ARG1, s_new_primitive);
SCM_ASSERT(scm_inexact_p(foo2) == SCM_BOOL_T, foo2, SCM_ARG2, s_new_primitive);
}
in addition, guile-interface.el sends header forms to the inferior scheme
process so that expressions get evaluated in the correct module context.
kind regards,
-russ
;;;
;;; $Id: guile-interface.el,v 1.14 1997/09/09 13:18:49 mcmanr Exp $
;;;
(require 'inf-lisp)
(require 'cl)
(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-send-header-forms ()
"go to the top of the buffer and examine top level
forms. send header ms to the inferior scheme process.
header forms are forms involving the guile module system
and forms to load code from slib. quit searching when
a non-header form is encountered."
(interactive)
(save-excursion
(goto-char (point-min))
(forward-list 1)
(forward-list -1)
(while (or (looking-at "(define-module")
(looking-at "(set-current-module")
(looking-at "(use-modules")
(looking-at "(require")
(looking-at "(display"))
(let ((here (point)))
(lisp-eval-defun)
(goto-char here)
(forward-list 2)
(forward-list -1)))))
(defun guile-send-definition ()
"Sends header forms, then the currrent definition,
to the inferior scheme process,"
(interactive)
(guile-send-header-forms)
(lisp-eval-defun))
(defun guile-send-region ()
"Sends header forms, then the current region to the
inferior scheme process. also send a silly form on the
end to make sure that the reader is not hanging waiting
on white space."
(interactive)
(let ((buf (current-buffer)))
(guile-send-header-forms)
(lisp-eval-region (point) (mark))
(comint-send-string
(get-process "inferior-lisp")
"(quote done-sending-region)\n")))
(defun guile-run-lisp ()
"wrapper around run-lisp from inf-lisp.el, that does some
snazzy buffer switching."
(interactive "")
(if (not (eq (process-status "inferior-lisp") 'run))
(let ((start-buf (current-buffer)))
(run-lisp inferior-lisp-program)
(switch-to-buffer start-buf))
(let ((start-buf (current-buffer))
(lisp-buf (get-buffer "*inferior-lisp*")))
(switch-to-buffer-other-window lisp-buf)
(goto-char (point-max))
(switch-to-buffer-other-window start-buf))))
(defun guile-procedure-documentation ()
"get the inferior lisp process to print the doc string
of the procedure whose name is under point. this involves
first setting the current module."
(interactive)
(guile-run-lisp)
(guile-send-header-forms)
(save-excursion
(let ((process (get-process "inferior-lisp")))
(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-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 inferior-lisp-program "/opt/guile/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-lisp))
(defun my-scheme-mode-hook ()
(turn-on-font-lock)
(define-key scheme-mode-map (read-kbd-macro "C-c r") 'guile-send-region)
(define-key scheme-mode-map (read-kbd-macro "C-c e") 'guile-send-definition)
(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") 'guile-run-lisp)
(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)
---
"If you want to build a ship, don't drum up people together to collect
wood and don't assign them tasks and work, but rather teach them to
long for the endless immensity of the sea." -- Antoine de Saint Exupery