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