code:
;;; guile-scheme.el --- Guile Scheme editing mode

;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free
;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;;; 02111-1307 USA

;;; Commentary:

;; Put the following lines in your ~/.emacs:
;;
;;   (require 'guile-scheme)
;;   (setq initial-major-mode 'scheme-interaction-mode)

;;; Code:

(require 'guile)
(require 'scheme)

(defgroup guile-scheme nil
  "Editing Guile-Scheme code"
  :group 'lisp)

(defvar guile-scheme-syntax-keywords
  '((begin 0) (if 1) (cond 0) (case 1) (do 2)
    quote syntax lambda and or else delay receive use-modules
    (match 1) (match-lambda 0) (match-lambda* 0)
    (let scheme-let-indent) (let* 1) (letrec 1) (and-let* 1)
    (let-syntax 1) (letrec-syntax 1) (syntax-rules 1) (syntax-case 2)))

(defvar guile-scheme-special-procedures
  '((catch 1) (lazy-catch 1) (stack-catch 1)
    map for-each (dynamic-wind 3)))

;; set indent functions
(dolist (x (append guile-scheme-syntax-keywords
		   guile-scheme-special-procedures))
  (when (consp x)
    (put (car x) 'scheme-indent-function (cadr x))))

(defconst guile-scheme-font-lock-keywords
  (eval-when-compile
    (list
     (list (concat "(\\(define\\*?\\("
		   ;; Function names.
		   "\\(\\|-public\\|-method\\|-generic\\)\\|"
		   ;; Macro names, as variable names.
		   "\\(-syntax\\|-macro\\)\\|"
		   ;; Others
		   "-\\sw+\\)\\)\\>"
		   ;; Any whitespace and declared object.
		   "\\s *(?\\(\\sw+\\)?")
	   '(1 font-lock-keyword-face)
	   '(5 (cond ((match-beginning 3) font-lock-function-name-face)
		     ((match-beginning 4) font-lock-variable-name-face)
		     (t font-lock-type-face)) nil t))
     (list (concat
	    "(" (regexp-opt
		 (mapcar (lambda (e)
			   (prin1-to-string (if (consp e) (car e) e)))
			 (append guile-scheme-syntax-keywords
				 guile-scheme-special-procedures)) 'words))
	   '(1 font-lock-keyword-face))
     '("<\\sw+>" . font-lock-type-face)
     '("\\<:\\sw+\\>" . font-lock-builtin-face)
     ))
  "Expressions to highlight in Guile Scheme mode.")

;;;
;;; Guile Scheme mode
;;;

(defvar guile-scheme-mode-map nil
  "Keymap for Guile Scheme mode.
All commands in `lisp-mode-shared-map' are inherited by this map.")

(unless guile-scheme-mode-map
  (let ((map (make-sparse-keymap "Guile-Scheme")))
    (setq guile-scheme-mode-map map)
    (cond ((boundp 'lisp-mode-shared-map)
	   (set-keymap-parent map lisp-mode-shared-map))
	  ((boundp 'shared-lisp-mode-map)
	   (set-keymap-parent map shared-lisp-mode-map)))
    (define-key map [menu-bar] (make-sparse-keymap))
    (define-key map [menu-bar guile-scheme] (cons "Guile-Scheme" map))
    (define-key map [uncomment-region]
      '("Uncomment Out Region" . (lambda (beg end)
                                   (interactive "r")
                                   (comment-region beg end '(4)))))
    (define-key map [comment-region] '("Comment Out Region" . comment-region))
    (define-key map [indent-region] '("Indent Region" . indent-region))
    (define-key map [indent-line] '("Indent Line" . lisp-indent-line))
    (define-key map "\e\C-i" 'guile-scheme-complete-symbol)
    (define-key map "\e\C-x" 'guile-scheme-eval-define)
    (define-key map "\C-x\C-e" 'guile-scheme-eval-last-sexp)
    (define-key map "\C-c\C-b" 'guile-scheme-eval-buffer)
    (define-key map "\C-c\C-r" 'guile-scheme-eval-region)
    (define-key map "\C-c:" 'guile-scheme-eval-expression)
    (define-key map "\C-c\C-a" 'guile-scheme-apropos)
    (define-key map "\C-c\C-d" 'guile-scheme-describe)
    (define-key map "\C-c\C-k" 'guile-scheme-kill-process)

    (put 'comment-region 'menu-enable 'mark-active)
    (put 'uncomment-region 'menu-enable 'mark-active)
    (put 'indent-region 'menu-enable 'mark-active)))

(defcustom guile-scheme-mode-hook nil
  "Normal hook run when entering `guile-scheme-mode'."
  :type 'hook
  :group 'guile-scheme)

;;;###autoload
(defun guile-scheme-mode ()
  "Major mode for editing Guile Scheme code.
Editing commands are similar to those of `scheme-mode'.

\\{scheme-mode-map}
Entry to this mode calls the value of `scheme-mode-hook'
if that value is non-nil."
  (interactive)
  (kill-all-local-variables)
  (setq mode-name "Guile Scheme")
  (setq major-mode 'guile-scheme-mode)
  (use-local-map guile-scheme-mode-map)
  (scheme-mode-variables)
  (setq mode-line-process
	'(:eval (if (processp guile-scheme-adapter)
		    (format " [%s]" guile-scheme-command)
		  "")))
  (setq font-lock-defaults
        '((guile-scheme-font-lock-keywords)
          nil t (("+-*/.<>=!?$%_&~^:@" . "w")) beginning-of-defun
          (font-lock-mark-block-function . mark-defun)))
  (run-hooks 'guile-scheme-mode-hook))

;;;
;;; Scheme interaction mode
;;;

(defvar scheme-interaction-mode-map ()
  "Keymap for Scheme Interaction mode.
All commands in `guile-scheme-mode-map' are inherited by this map.")

(unless scheme-interaction-mode-map
  (let ((map (make-sparse-keymap)))
    (setq scheme-interaction-mode-map map)
    (set-keymap-parent map guile-scheme-mode-map)
    (define-key map "\C-j" 'guile-scheme-eval-print-last-sexp)
    ))

(defvar scheme-interaction-mode-hook nil
  "Normal hook run when entering `scheme-interaction-mode'.")

(defun scheme-interaction-mode ()
  "Major mode for evaluating Scheme expressions with Guile.

\\{scheme-interaction-mode-map}"
  (interactive)
  (guile-scheme-mode)
  (use-local-map scheme-interaction-mode-map)
  (setq major-mode 'scheme-interaction-mode)
  (setq mode-name "Scheme Interaction")
  (run-hooks 'scheme-interaction-mode-hook))

;;;
;;; Guile Scheme adapter
;;;

(defvar guile-scheme-command "guile")
(defvar guile-scheme-adapter nil)
(defvar guile-scheme-module nil)

(defun guile-scheme-adapter ()
  (if (and (processp guile-scheme-adapter)
	   (eq (process-status guile-scheme-adapter) 'run))
      guile-scheme-adapter
    (setq guile-scheme-module nil)
    (setq guile-scheme-adapter
	  (guile:make-adapter guile-scheme-command 'emacs-scheme-channel))))

(defun guile-scheme-set-module ()
  "Set the current module based on buffer contents.
If there is a (define-module ...) form, evaluate it.
Otherwise, choose module (guile-user)."
  (save-excursion
    (let ((module (if (re-search-backward "^(define-module " nil t)
		      (let ((start (match-beginning 0)))
			(goto-char start)
			(forward-sexp)
			(buffer-substring-no-properties start (point)))
		    "(define-module (emacs-user))")))
      (unless (string= guile-scheme-module module)
	(prog1 (guile:eval module (guile-scheme-adapter))
	  (setq guile-scheme-module module))))))

(defun guile-scheme-eval-string (string)
  (guile-scheme-set-module)
  (guile:eval string (guile-scheme-adapter)))

(defun guile-scheme-display-result (value flag)
  (if (string= value "#<unspecified>")
      (setq value "done"))
  (if flag
      (insert value)
    (message "%s" value)))

;;;
;;; Interactive commands
;;;

(defun guile-scheme-eval-expression (string)
  "Evaluate the expression in STRING and show value in echo area."
  (interactive "SGuile Scheme Eval: ")
  (guile-scheme-display-result (guile-scheme-eval-string string) nil))

(defun guile-scheme-eval-region (start end)
  "Evaluate the region as Guile Scheme code."
  (interactive "r")
  (guile-scheme-eval-expression (buffer-substring-no-properties start end)))

(defun guile-scheme-eval-buffer ()
  "Evaluate the current buffer as Guile Scheme code."
  (interactive)
  (guile-scheme-eval-expression (buffer-string)))

(defun guile-scheme-eval-last-sexp (arg)
  "Evaluate sexp before point; show value in echo area.
With argument, print output into current buffer."
  (interactive "P")
  (guile-scheme-display-result
   (guile-scheme-eval-string
    (buffer-substring-no-properties
     (point) (save-excursion (backward-sexp) (point)))) arg))

(defun guile-scheme-eval-print-last-sexp ()
  "Evaluate sexp before point; print value into current buffer."
  (interactive)
  (let ((start (point)))
    (guile-scheme-eval-last-sexp t)
    (insert "\n")
    (save-excursion (goto-char start) (insert "\n"))))

(defun guile-scheme-eval-define ()
  (interactive)
  (guile-scheme-eval-region (save-excursion (end-of-defun) (point))
			    (save-excursion (beginning-of-defun) (point))))

(defun guile-scheme-load-file (file)
  "Load a Guile Scheme file."
  (interactive "fGuile Scheme load file: ")
  (guile-scheme-eval-string (format "(load %s)" (expand-file-name file)))
  (message "done"))

(guile-import guile-emacs-complete-alist)

(defun guile-scheme-complete-symbol ()
  (interactive)
  (let* ((end (point))
	 (start (save-excursion (skip-syntax-backward "w_") (point)))
	 (pattern (buffer-substring-no-properties start end))
	 (alist (guile-emacs-complete-alist pattern)))
    (goto-char end)
    (let ((completion (try-completion pattern alist)))
      (cond ((eq completion t))
	    ((not completion)
	     (message "Can't find completion for \"%s\"" pattern)
	     (ding))
	    ((not (string= pattern completion))
	     (delete-region start end)
	     (insert completion))
	    (t
	     (message "Making completion list...")
	     (with-output-to-temp-buffer "*Completions*"
	       (display-completion-list alist))
	     (message "Making completion list...done"))))))

(guile-import guile-emacs-apropos)

(defun guile-scheme-apropos (regexp)
  (interactive "sGuile Scheme apropos (regexp): ")
  (guile-scheme-set-module)
  (with-output-to-temp-buffer "*Help*"
    (princ (guile-emacs-apropos regexp))))

(guile-import guile-emacs-describe)

(defun guile-scheme-describe (symbol)
  (interactive (list (guile-scheme-input-symbol "Describe Guile variable")))
  (guile-scheme-set-module)
  (with-output-to-temp-buffer "*Help*"
    (princ (guile-emacs-describe symbol))))

(defun guile-scheme-kill-process ()
  (interactive)
  (if guile-scheme-adapter
      (guile-process-kill guile-scheme-adapter))
  (setq guile-scheme-adapter nil))

;;;
;;; Internal functions
;;;

(guile-import apropos-internal guile-apropos-internal)

(defvar guile-scheme-complete-table (make-vector 151 nil))

(defun guile-scheme-input-symbol (prompt)
  (mapc (lambda (sym)
	  (if (symbolp sym)
	      (intern (symbol-name sym) guile-scheme-complete-table)))
	(guile-apropos-internal ""))
  (let* ((str (thing-at-point 'symbol))
	 (default (if (intern-soft str guile-scheme-complete-table)
		      (concat " (default " str ")")
		    "")))
    (intern (completing-read (concat prompt default ": ")
			     guile-scheme-complete-table nil t nil nil str))))

;;;
;;; Turn on guile-scheme-mode for .scm files by default.
;;;

(setq auto-mode-alist
      (cons '("\\.scm\\'" . guile-scheme-mode) auto-mode-alist))

(provide 'guile-scheme)

;;; guile-scheme.el ends here


code:
;;; guile.el --- Emacs Guile interface

;; Copyright (C) 2001 Keisuke Nishida <kxn30@po.cwru.edu>

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free
;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;;; 02111-1307 USA

;;; Code:

(require 'cl)

;;;
;;; Low level interface
;;;

(defvar guile-emacs-file
  (catch 'return
    (mapc (lambda (dir)
	    (let ((file (expand-file-name "guile-emacs.scm" dir)))
	      (if (file-exists-p file) (throw 'return file))))
	  load-path)
    (error "Cannot find guile-emacs.scm")))

(defvar guile-channel-file
  (catch 'return
    (mapc (lambda (dir)
	    (let ((file (expand-file-name "channel.scm" dir)))
	      (if (file-exists-p file) (throw 'return file))))
	  load-path)
    (error "Cannot find channel.scm")))

(defvar guile-libs
  (nconc (if guile-channel-file (list "-l" guile-channel-file) '())
	 (list "-l" guile-emacs-file)))

;;;###autoload
(defun guile:make-adapter (command channel)
  (let* ((buff (generate-new-buffer " *guile object channel*"))
	 (libs (if guile-channel-file (list "-l" guile-channel-file) nil))
	 (proc (apply 'start-process "guile-oa" buff command "-q" guile-libs)))
    (process-kill-without-query proc)
    (accept-process-output proc)
    (guile-process-require proc (format "(%s)\n" channel) "channel> ")
    proc))

(put 'guile-error 'error-conditions '(guile-error error))
(put 'guile-error 'error-message "Guile error")

(defvar guile-token-tag "<guile>")

(defun guile-tokenp (x) (and (consp x) (eq (car x) guile-token-tag)))

;;;###autoload
(defun guile:eval (string adapter)
  (condition-case error
      (let ((output (guile-process-require adapter (concat "eval " string "\n")
					   "channel> ")))
	(cond
	 ((string= output "") nil)
	 ((string-match "^\\(\\(value\\)\\|\\(token\\)\\|\\(exception\\)\\) = "
			output)
	  (cond
	   ;; value
	   ((match-beginning 2)
	    (car (read-from-string (substring output (match-end 0)))))
	   ;; token
	   ((match-beginning 3)
	    (cons guile-token-tag
		  (car (read-from-string (substring output (match-end 0))))))
	   ;; exception
	   ((match-beginning 4)
	    (signal 'guile-error
		    (car (read-from-string (substring output (match-end 0))))))))
	 (t
	  (error "Unsupported result" output))))
    (quit
     (signal-process (process-id adapter) 'SIGINT)
     (signal 'quit nil))))

;;;
;;; Guile Lisp adapter
;;;

(defvar guile-lisp-command "guile")
(defvar guile-lisp-adapter nil)

(defvar true "#t")
(defvar false "#f")

(unless (boundp 'keywordp)
  (defun keywordp (x) (and (symbolp x) (eq (aref (symbol-name x) 0) ?:))))

(defun guile-lisp-adapter ()
  (if (and (processp guile-lisp-adapter)
	   (eq (process-status guile-lisp-adapter) 'run))
      guile-lisp-adapter
    (setq guile-lisp-adapter
	  (guile:make-adapter guile-lisp-command 'emacs-lisp-channel))))

(defun guile-lisp-convert (x)
  (cond
   ((or (eq x true) (eq x false)) x)
   ((null x) "'()")
   ((keywordp x) (concat "#" (prin1-to-string x)))
   ((stringp x) (prin1-to-string x))
   ((guile-tokenp x) (cadr x))
   ((consp x)
    (if (null (cdr x))
	(list (guile-lisp-convert (car x)))
      (cons (guile-lisp-convert (car x)) (guile-lisp-convert (cdr x)))))
   (t x)))

;;;###autoload
(defun guile-lisp-eval (form)
  (guile:eval (format "%s" (guile-lisp-convert form)) (guile-lisp-adapter)))

(defun guile-lisp-flat-eval (&rest form)
  (let ((args (mapcar (lambda (x)
			(if (guile-tokenp x) (cadr x) (list 'quote x)))
		      (cdr form))))
    (guile-lisp-eval (cons (car form) args))))

;;;###autoload
(defmacro guile-import (name &optional new-name &rest opts)
  `(guile-process-import ',name ',new-name ',opts))

(defun guile-process-import (name new-name opts)
  (let ((real (or new-name name))
	(docs (if (memq :with-docs opts) true false)))
    (eval (guile-lisp-eval `(guile-emacs-export ',name ',real ,docs)))))

;;;###autoload
(defmacro guile-use-module (name)
  `(guile-lisp-eval '(use-modules ,name)))

;;;###autoload
(defmacro guile-import-module (name &rest opts)
  `(guile-process-import-module ',name ',opts))

(defun guile-process-import-module (name opts)
  (unless (boundp 'guile-emacs-export-procedures)
    (guile-import guile-emacs-export-procedures))
  (let ((docs (if (memq :with-docs opts) true false)))
    (guile-lisp-eval `(use-modules ,name))
    (eval (guile-emacs-export-procedures name docs))
    name))

;;;
;;; Process handling
;;;

(defvar guile-process-output-start nil)
(defvar guile-process-output-value nil)
(defvar guile-process-output-finished nil)
(defvar guile-process-output-separator nil)

(defun guile-process-require (process string separator)
  (setq guile-process-output-value nil)
  (setq guile-process-output-finished nil)
  (setq guile-process-output-separator separator)
  (let (temp-buffer)
    (unless (process-buffer process)
      (setq temp-buffer (guile-temp-buffer))
      (set-process-buffer process temp-buffer))
    (with-current-buffer (process-buffer process)
      (goto-char (point-max))
      (insert string)
      (setq guile-process-output-start (point))
      (set-process-filter process 'guile-process-filter)
      (process-send-string process string)
      (while (not guile-process-output-finished)
	(unless (accept-process-output process 3)
	  (when (> (point) guile-process-output-start)
	    (display-buffer (current-buffer))
	    (error "BUG in Guile object channel!!")))))
    (when temp-buffer
      (set-process-buffer process nil)
      (kill-buffer temp-buffer)))
  guile-process-output-value)

(defun guile-process-filter (process string)
  (with-current-buffer (process-buffer process)
    (insert string)
    (forward-line -1)
    (if (< (point) guile-process-output-start)
	(goto-char guile-process-output-start))
    (when (re-search-forward guile-process-output-separator nil 0)
      (goto-char (match-beginning 0))
      (setq guile-process-output-value
	    (buffer-substring guile-process-output-start (point)))
      (setq guile-process-output-finished t))))

(defun guile-process-kill (process)
  (set-process-filter process nil)
  (delete-process process)
  (if (process-buffer process)
      (kill-buffer (process-buffer process))))

(provide 'guile)

;;; guile.el ends here

license: mit


code:
;;; multistring.el --- editing multiline strings.

;; Copyright (C) 2000, 2006 Free Software Foundation, Inc.

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free
;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;;; 02111-1307 USA

;;; Author: Mikael Djurfeldt <djurfeldt@nada.kth.se>

;;; Commentary:

;; Commands for editing multiline ANSI C compatible string literals.

;;; Code:

(defun ms-ansify-string (arg)
    "Convert a string literal spanning multiple lines into multiple literals.
With no argument, convert the single string at point to multiple strings.
With an argument, convert multiple strings to a single one.

ANSI C doesn't allow a string literal to span multiple lines.  This
function makes editing of multiline strings easier.

The programmer can edit a string spanning multiple lines and then use
this function to convert it into multiple literals representing the
original string through the ANSI C string concatenation feature:

  \"A string consisting of
  multiple
  lines.\"

is converted into

  \"A string consisting of\n\"
  \"multiple\n\"
  \"lines\""
  (interactive "*P")
  (save-excursion
    (let (beg end)
      (save-restriction
	(ms-narrow-canonicalize-ansi-c-string)
	(if (not arg)
	    (ms-break-string))
	(setq beg (point-min))
	(setq end (point-max)))
      (if (not arg)
	  (c-indent-region beg end)))))

(defun ms-pack-region (from to &optional unpack-flag)
  "Pack paragraphs into single lines and remove one newline after paragraphs.
With no argument, do the conversion.
With an argument, do the reverse.

When doing the reverse conversion, \\[fill-region] is used to break up
the text into multiple lines."
  (interactive "*r\nP")
  (save-excursion
    (save-restriction
      (narrow-to-region from to)
      (if (not unpack-flag)
	  (ms-pack-buffer)
	(ms-unpack-buffer)))))

(defun ms-pack-ansify-string (arg)
  "Pack text in a string literal and convert into multiple literals.
With no argument, do the conversion.
With an argument, do the reverse.

This command has the combined effect of \\[ms-pack-region] and
\\[ms-ansify-string].  It is typically used if you want to store
entire paragraphs without newlines in an ANSI C literal, but want to
split it into multiple literals in order for the program text to look
sensible.  Using the reverse command, you can \"unpack\" the text,
edit it and repack the text using the forward conversion."
  (interactive "*P")
  (save-excursion
    (let (beg end)
      (save-restriction
	(ms-narrow-canonicalize-ansi-c-string)
	(if (not arg)
	    (ms-break-string " " "" "\\n")
	  (ms-unpack-buffer))
	(setq beg (point-min))
	(setq end (point-max)))
      (if (not arg)
	  (c-indent-region beg end)))))

(defun ms-pack-buffer ()
  "Pack paragraphs into single lines and remove one newline after paragraphs."
  (interactive "*")
  (goto-char (point-min))
  (skip-chars-forward "^\n")
  (while (not (eobp))
    (delete-char 1)
    (skip-chars-forward "\n")
    (skip-chars-forward "^\n")))

(defun ms-unpack-buffer ()
  "Break single lines into paragraphs and add an extra newline between each."
  (interactive "*")
  (goto-char (point-min))
  (skip-chars-forward "^\n")
  (while (not (eobp))
    (insert ?\n)
    (skip-chars-forward "\n")
    (skip-chars-forward "^\n"))
  (fill-region (point-min) (point-max) nil t))

(defconst ms-whitespace " \t\n")
(defconst ms-string-beginning "\"")
(defconst ms-string-end "\\(\\\\*\\)\"")
(defconst ms-quoted-newline "\\(\\\\*\\)\\(\\\\n\\)")

(defun ms-in-string-p ()
  (eq (c-in-literal) 'string))

(defun ms-narrow-canonicalize-ansi-c-string ()
  ;; Find and check reference point
  (cond ((ms-in-string-p))
	((eq (char-after) ?\") (forward-char))
	(t (error "Not in string.")))
  (set-mark (point))
  ;; Find beginning
  (ms-beginning-of-string)
  (let ((beg (point)))
    ;; Extend string backwards
    (while (ms-extend-backwards)
      (setq beg (point)))
    (goto-char (mark))
    ;; Find end
    (ms-end-of-string)
    (let ((end (point)))
      ;; Extend string forwards
      (while (ms-extend-forwards)
	(setq end (point)))
      ;; Narrow
      (narrow-to-region beg end)
      ;; Convert \n into explicit newlines
      (ms-convert-quoted-newlines))))

(defun ms-beginning-of-string ()
  (let ((pos (search-backward ms-string-beginning nil t)))
    (while (and pos
		(char-before)
		(eq (char-before) ?\\))
      (setq pos (search-backward ms-string-beginning nil t)))
    (if pos
	(progn
	  (forward-char)
	  (1+ pos)))))

(defun ms-extend-backwards ()
  (let ((end (point)))
    (backward-char)
    (skip-chars-backward ms-whitespace)
    (if (eq (char-before) ?\")
	(progn
	  (backward-char)
	  (delete-region (point) end)
	  (ms-beginning-of-string)))))

(defun ms-end-of-string ()
  (let ((pos (search-forward-regexp ms-string-end nil t)))
    (while (and pos (= (logand (- (match-end 1) (match-beginning 1)) 1) 1))
      (setq pos (search-forward-regexp ms-string-end nil t)))
    (if pos
	(progn
	  (backward-char)
	  (match-end 1)))))

(defun ms-extend-forwards ()
  (let ((start (point)))
    (forward-char)
    (skip-chars-forward ms-whitespace)
    (if (eq (char-after) ?\")
	(progn
	  (forward-char)
	  (delete-region start (point))
	  (ms-end-of-string)))))

(defun ms-convert-quoted-newlines ()
  (goto-char (point-min))
  (while (search-forward-regexp ms-quoted-newline nil t)
    (if (= (logand (- (match-end 1) (match-beginning 1)) 1) 0)
	(replace-match "\n" nil t nil 2))))

(defun ms-break-string (&optional single-term multi-term-1 multi-term-n)
  (let ((single-term (or single-term "\\n"))
	(multi-term-1 (or multi-term-1 "\\n"))
	(multi-term-n (or multi-term-n "\\n")))
    (goto-char (point-min))
    (skip-chars-forward "^\n")
    (while (not (eobp))
      (delete-char 1)
      (if (not (eq (char-after) ?\n))
	  (insert single-term)
	(insert multi-term-1)
	(while (eq (char-after) ?\n)
	  (delete-char 1)
	  (insert multi-term-n)))
      (insert "\"\n\"")
      (skip-chars-forward "^\n"))))

(eval-after-load "cc-mode"
  (progn
    (define-key c-mode-base-map "\C-ca" 'ms-ansify-string)
    (define-key c-mode-base-map "\C-cd" 'ms-pack-ansify-string)
    ))


code:
;;; patch.el --- mail/apply a patch

;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free
;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;;; 02111-1307 USA

;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
;;; Version: 1
;;; Favorite-Favorite: Favorite-Favorite

;;; Commentary:

;; This file has two symmetrical usage modes, for patch creation and
;; application, respectively.  The details are somewhat tuned for Guile
;; maintenance; probably we should generalize it a bit and add it to
;; Emacs proper at some point in the future.  Long live free software!
;;
;; On the patch creation side of things, there are various version
;; control systems that are happy to write a diff to stdout (and
;; numerous Emacs interfaces to them all).  Thus, we provide only a
;; simple `patch-send' that composes mail from the current buffer;
;; the contents of that buffer are left as an exercise for the patch
;; creator.  When preparing the mail, `patch-send' scans the patch
;; for standard filename headers and sets up a skeleton change log --
;; filling this in is a good way to earn respect from maintainers (hint
;; hint).  Type `C-c C-c' to send the mail when you are done.  (See
;; `compose-mail' for more info.)
;;
;; TODO: Write/document patch-apply side of things.
;; TODO: Integrate w/ `ediff-patch-buffer' et al.

;;; Code:

(require 'cl)
(require 'update-changelog)             ; for stitching

;; outgoing

(defvar patch-greeting "hello guile maintainers,\n\n"
  "*String to insert at beginning of patch mail.")

(defun patch-scan-files ()
  (let (files)
    (save-excursion
      (while (re-search-forward "^[+][+][+] \\(\\S-+\\)" (point-max) t)
        (setq files (cons (cons (match-string 1)
                                (match-beginning 0))
                          files))))
    (reverse files)))

(defun patch-common-prefix (filenames)
  (let* ((first-file (car filenames))
         (prefix (and first-file (file-name-directory first-file))))
    (while (and prefix
                (not (string= "" prefix))
                (not (every (lambda (filename)
                              (string-match (concat "^" prefix) filename))
                            filenames)))
      (setq prefix (file-name-directory (substring prefix 0 -1))))
    prefix))

(defun patch-changelog-skeleton ()
  (let* ((file-info (patch-scan-files))
         (fullpath-files (mapcar 'car file-info))
         (cut (length (patch-common-prefix fullpath-files)))
         (files (mapcar (lambda (fullpath-file)
                          (substring fullpath-file cut))
                        fullpath-files)))
    (mapconcat
     (lambda (file)
       (concat (make-string (length file) ?_) "\n" file "\n[writeme]"))
     files
     "\n")))

(defun patch-send (buffer subject)
  (interactive "bBuffer: \nsSubject: ")
  (when (string= "" subject)
    (error "(empty subject)"))
  (compose-mail "bug-guile@gnu.org" subject)
  (insert (with-current-buffer buffer (buffer-string)))
  (mail-text)
  (insert patch-greeting)
  (save-excursion
    (insert "here is a patch ... [overview/observations/etc]\n\n"
            (patch-changelog-skeleton) "\n\n\n"
            (make-string 72 ?_) "\n")))

;; incoming

;;; patch.el ends here


code:
;;; ppexpand.el --- temporarily expanding macros in a pretty way.

;; Copyright (C) 2000, 2006 Free Software Foundation, Inc.

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free
;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;;; 02111-1307 USA

;;; Author: Mikael Djurfeldt <djurfeldt@nada.kth.se>

;;; Commentary:

;; Commands for editing multiline ANSI C compatible string literals.

;;; Code:
(require 'cmacexp)

(defvar if-mark "#if 0 /* PPEXPAND */")
(defvar else-mark "#else /* PPEXPAND */")
(defvar endif-mark "#endif /* PPEXPAND */")

(define-key c-mode-map "\C-ce" 'ppexpand)

(defun ppexpand (start end &optional undo)
  "Expand C macros in the region, using the C preprocessor.
The expanded code is run through the `indent' command and inserted
into the program next to the original code, using an #if/#else/#endif
construct.

Given a prefix argument, it reverts the change, removing the
#if/#else/#endif construct and the expanded code.

`c-macro-preprocessor' specifies the preprocessor to use.
Prompt for arguments to the preprocessor \(e.g. `-DDEBUG -I ./include')
if the user option `c-macro-prompt-flag' is non-nil.

Noninteractive args are START, END, UNDO.
For use inside Lisp programs, see also `c-macro-expansion'."

  (interactive (if current-prefix-arg
		   (list nil nil t)
		 (let ((pos1 (point))
		       (pos2 (mark)))
		   (if (< pos1 pos2)
		       (list pos1 pos2 nil)
		     (list pos2 pos1 nil)))))
  (let ((inbuf (current-buffer)))
    ;; Build the command string.
    (if c-macro-prompt-flag
	(setq c-macro-cppflags
	      (read-string "Preprocessor arguments: "
			   c-macro-cppflags)))
    (if undo
	(let ((pos (point)) if-pos else-pos endif-pos)
	  (save-excursion
	    (end-of-line)
	    (if (not (and (setq if-pos (search-backward if-mark nil t))
			  (setq else-pos (search-forward else-mark nil t))
			  (setq endif-pos (search-forward endif-mark nil t))
			  (<= if-pos pos)
			  (< pos endif-pos)))
		(error "Not in ppexpanded region"))
	    (let ((orig (buffer-substring (+ if-pos (length if-mark) 1)
					  (- else-pos (length else-mark)))))
	      (delete-region if-pos (+ endif-pos 1))
	      (insert orig))))
      ;; Expand the macro.
      (let* ((expansion (c-macro-expansion start end
					   (concat c-macro-preprocessor " "
						   c-macro-cppflags) t))
	     (orig (buffer-substring start end)))
	(setq expansion
	      (with-temp-buffer
		(insert expansion)
		(call-process-region (point-min) (point-max) "indent"
				     t		;delete the text
				     t		;output --> current buffer
				     )
		(buffer-string)))
	(delete-region start end)
	(insert if-mark ?\n orig else-mark ?\n expansion endif-mark ?\n)))))


code:
;;; update-changelog.el --- stitch rcs2log output to ChangeLog

;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free
;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;;; 02111-1307 USA

;;; Commentary:

;; Usage: emacs -batch -l update-changelog.el
;;
;; This program is basically a wrapper around rcs2log, and inherits rcs2log's
;; weaknesses, namely, the requirement that there be a checked out (working
;; directory) copy.  It would be nice if rcs2log grokked with the repository
;; directly, but until then, we work around it by requiring the environment
;; var `LOCAL_WORK_ROOT' to be defined.  This should be a directory under
;; which cvs modules are checked out.
;;
;; Flash!  Newer versions of rcs2log do indeed understand the repository,
;; and can be invoked with "-R" therein.  We infer this if `LOCAL_WORK_ROOT'
;; is not set, and use instead `CVSROOT'.  At least one of these must be set.
;;
;; You can pass additional options to rcs2log using env var `RCS2LOG_OPTS'.
;;
;; Usage from a Lisp program:
;;   (ucl-update filename) -- Update FILENAME, a Change Log file

;;; Code:

;;;---------------------------------------------------------------------------
;;; Variables

(defvar ucl-o (or (getenv "RCS2LOG_OPTS") "")
  "Additional options to pass to rcs2log.")

;;;---------------------------------------------------------------------------
;;; Cleanup functions

(defun ucl-stitch-new-old (new-old &rest ignore)
  "In a changelog buffer, remove redundancy around NEW-OLD point.
The new text is before NEW-OLD point, and the old after."
  (goto-char new-old)
  (or (= new-old (point-max))		; no old
      (let ((last-new
	     (save-excursion
	       (buffer-substring (re-search-backward "^[0-9]+") new-old))))
	(let ((has-diff (string-match "\n\tdiff.*-r" last-new))) ; ugh
	  (and has-diff (setq last-new (substring last-new 0 has-diff))))
	(let ((overlap (search-forward last-new (point-max) t)))
	  (and overlap (delete-region new-old overlap))))))

;; Sometimes wannabe developers append diffs to their log entries.
(defun ucl-omit-diffs (&rest ignore)
  "In a changelog buffer, delete diffs (assumed at end of entry)."
  (goto-char (point-min))
  (while (re-search-forward "^\tdiff .*-r" (point-max) t)
    (beginning-of-line)
    (delete-region (point)
		   (save-excursion
		     (if (re-search-forward "^[0-9]+" (point-max))
			 (- (point) 4)
		       (point-max))))))

(defun ucl-space-out-entries (&rest ignore)
  "In a changelog buffer, ensure proper spacing between entries."
  (goto-char (point-max))
  (while (re-search-backward "^[0-9]+" (point-min) t)
    (unless (= (point) (point-min))
      (open-line 3)			; yuk
      (delete-blank-lines))))

(defun ucl-kill-eol-white-space (&rest ignore)
  "In a changelog buffer, delete end-of-line white space."
  (goto-char (point-min))
  (while (re-search-forward "[ \t]+$" (point-max) t)
    (delete-region
     (match-beginning 0) (match-end 0))))

(defvar ucl-cleanup-hook '(ucl-stitch-new-old
			   ucl-omit-diffs
			   ucl-space-out-entries
			   ucl-kill-eol-white-space)
  "Hook run after combining the new fragment with the old changelog.  These
are called with the argument NEW-OLD, which is the buffer position at the
boundary of the two pieces of text.  This is suboptimal; we should use a
marker so that munges on the text do not lose this position.  The result is
that currently, `ucl-stitch-new-old' must be called first because it depends
on NEW-OLD, while the other cleanup funcs ignore it.  (Sigh.)")

;;;---------------------------------------------------------------------------
;;; Update functions

(defun ucl-root ()
  (let ((lwr (getenv "LOCAL_WORK_ROOT"))
	(cr  (getenv "CVSROOT")))
    (concat (or lwr
		(and cr (progn
			  (setq ucl-o (concat "-R " ucl-o))	; hmm
			  cr))
		(error "Must set env var LOCAL_WORK_ROOT or CVSROOT"))
	    "/")))

(defun ucl-update (filename)
  (interactive "fChangeLog: ")
  (let* ((ofile (expand-file-name filename))
         (cmd   (concat "rcs2log " ucl-o " -c " ofile))
         (obuf  "*ucl-work*"))
    (when (and (file-exists-p ofile)
	       (progn
		 (shell-command cmd obuf)
		 (get-buffer obuf)))
      (save-excursion			; prevent default-directory hosing
	(set-buffer obuf)
	(unless (= 0 (buffer-size))
	  (let ((new-old-boundary (point-max)))
	    (goto-char new-old-boundary)
	    (insert-file ofile)
	    (run-hook-with-args 'ucl-cleanup-hook new-old-boundary))
	  (or (= (buffer-size) (nth 7 (file-attributes ofile)))
	      (let (make-backup-files)	; less clutter
		(write-file ofile))))
	(kill-buffer (current-buffer))))))

;;;---------------------------------------------------------------------------
;;; Load-time actions

(when noninteractive			; only when `-batch'
  (or (ucl-update "ChangeLog")
      (message "Sorry, could not update ChangeLog in %s" default-directory)))

(provide 'update-changelog)

;;; update-changelog.el ends here


code:
2008-01-22  Neil Jerram  <neil@ossau.uklinux.net>

	* compat/compat.h: Update copyright statement to LGPL.

2002-11-17  Mikael Djurfeldt  <mdj@linnaeus>

	* README: Added description of compat.

	* compat/acconfig.h, compat/acinclude.m4, compat.h, configure.in:
	New files.

2001-07-24  Martin Grabmueller  <mgrabmue@cs.tu-berlin.de>

	All examples are now built and tested on `make installcheck'
	rather than `make check'.

2001-07-19  Martin Grabmueller  <mgrabmue@cs.tu-berlin.de>

	* box-dynamic-module/Makefile.am, box-dynamic/Makefile.am,
	box-module/Makefile.am, box/Makefile.am: Use $(top_srcdir) to get
	at GUILE_LOAD_PATH, and $(top_builddir) for the guile and
	guile-config programs and for the link paths.  Add check.test to
	EXTRA_DIST.

	* box-dynamic-module/Makefile.am, box-dynamic/Makefile.am,
	box-module/Makefile.am, box/Makefile.am: Add -L../../qt to LIBS.

2001-07-19  Rob Browning  <rlb@defaultvalue.org>

	* box-module/.cvsignore: add .deps

	* box/.cvsignore: add .deps.

2001-07-17  Martin Grabmueller  <mgrabmue@cs.tu-berlin.de>

	* box-module/Makefile.am (TESTS): New variable.
	Create `box' on `make all'.

	* box-module/check.test, box-dynamic-module/check.test,
	* box-dynamic/check.test: New files.

	* box-dynamic/Makefile.am (libbox): Create box library on `make
	all'.
	(TESTS): New variable.

	* box/Makefile.am (TESTS): New variable.
	Create `box' program on `make all', use freshly built Guile for
	building.

	* box/check.test: New file.

	* modules/check.test, safe/check.test, scripts/check.test: Set
	GUILE_LOAD_PATH to make the tests run without installed Guile.

2001-07-16  Thien-Thi Nguyen  <ttn@revel.glug.org>

	* scripts/check.test: Add check for guile interpreter.
	Fix bug: Use `$guile' everywhere.  Thanks to Martin Grabmueller.

2001-07-16  Martin Grabmueller  <mgrabmue@cs.tu-berlin.de>

	* modules/check.test, safe/check.test: New files.

	* modules/Makefile.am (TESTS), safe/Makefile.am (TESTS): New
	variables.

2001-07-14  Thien-Thi Nguyen  <ttn@revel.glug.org>

	* scripts/check.test: New file.

	* Makefile.am (TESTS): New var.

2001-07-14  Martin Grabmueller  <mgrabmue@cs.tu-berlin.de>

	* modules/main: Use :renamer for specifying renaming procedure.

2001-07-10  Thien-Thi Nguyen  <ttn@revel.glug.org>

	* scripts/hello (display-version, display-help): Fix comment; nfc.

2001-07-09  Martin Grabmueller  <mgrabmue@cs.tu-berlin.de>

	* box-dynamic/README: Corrected sample session.

	* box-module/box.c, box-dynamic-module/box.c, box-dynamic/box.c
	* box/box.c: scm_bits_t -> scm_t_bits.

2001-06-18  Martin Grabmueller  <mgrabmue@cs.tu-berlin.de>

	* box-dynamic-module/README: Use a better example for box-map, as
	suggested by Thomas Wawrzinek.

2001-06-14  Martin Grabmueller  <mgrabmue@cs.tu-berlin.de>

	* scripts/README, scripts/hello.scm, safe/untrusted.scm,
	safe/evil.scm, safe/README, modules/README, modules/main,
	modules/module-0.scm, modules/module-1.scm, modules/module-2.scm:
	Minor cleanup.

	* README: Added intro stuff, restructured a bit.

	* box-dynamic/README, box-module/README, box/README: Cleanup and
	restructuring.

	* box-dynamic-module/box-mixed.scm: New file, demonstrating usage
	of extension library functionality, but without exporting
	procedures from the library.

	Thanks to Thomas Wawrzinek for the idea and example code!

	* box-dynamic-module/box-module.scm: Add comments, export
	make-box, box-ref, box-set!.

	* box-dynamic-module/README: Integrate new module (box-mixed),
	restructure and cleanup a bit.

2001-06-06  Martin Grabmueller  <mgrabmue@cs.tu-berlin.de>

	* box-dynamic-module/box-module.scm: New file.

2001-06-05  Martin Grabmueller  <mgrabmue@cs.tu-berlin.de>

	* box-dynamic-module: New directory, implements the box type in a
	shared library and places the definitions in a C-only module.

	Thanks to Thomas Wawrzinek for this, too!

	* box-dynamic/box.c, box/box.c, box-dynamic-module/box.c,
	box-module/box.c (mark_box): Fixed typo in comment.

2001-06-01  Rob Browning  <rlb@cs.utexas.edu>

	* .cvsignore: here and in all subdirectories listing Makefile and
	Makefile.in.

2001-05-31  Martin Grabmueller  <mgrabmue@cs.tu-berlin.de>

	* box-dynamic: New directory, implements the box type in a shared
	library (aka extension)

	Thanks to Thomas Wawrzinek for patching box.c into an extension!

2001-05-30  Martin Grabmueller  <mgrabmue@cs.tu-berlin.de>

	* box-module: New directory, similar to box, but defines the
	primitives in a module (box-module) instead of defining them
	globally.

	* safe: New directory, explaining some aspects of using safe
	environments for evaluation.

2001-05-29  Martin Grabmueller  <mgrabmue@cs.tu-berlin.de>

	* New directory for Guile example code.


code:
## Process this file with Automake to create Makefile.in
##
##   Copyright (C) 2001, 2006, 2008, 2009 Free Software Foundation, Inc.
##
##   This file is part of GUILE.
##
##   GUILE is free software; you can redistribute it and/or modify it
##   under the terms of the GNU Lesser General Public License as
##   published by the Free Software Foundation; either version 3, or
##   (at your option) any later version.
##
##   GUILE is distributed in the hope that it will be useful, but
##   WITHOUT ANY WARRANTY; without even the implied warranty of
##   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##   GNU Lesser General Public License for more details.
##
##   You should have received a copy of the GNU Lesser General Public
##   License along with GUILE; see the file COPYING.LESSER.  If not,
##   write to the Free Software Foundation, Inc., 51 Franklin Street,
##   Fifth Floor, Boston, MA 02110-1301 USA

EXTRA_DIST = README ChangeLog-2008 check.test				\
									\
 scripts/README scripts/simple-hello.scm scripts/hello			\
 scripts/fact								\
									\
 box/README box/box.c							\
									\
 box-module/README box-module/box.c					\
									\
 box-dynamic/README box-dynamic/box.c					\
									\
 box-dynamic-module/README box-dynamic-module/box.c			\
 box-dynamic-module/box-module.scm box-dynamic-module/box-mixed.scm	\
									\
 modules/README modules/module-0.scm modules/module-1.scm		\
 modules/module-2.scm modules/main					\
									\
 safe/README safe/safe safe/untrusted.scm safe/evil.scm

AM_CFLAGS = `PATH=$(bindir)$(PATH_SEPARATOR)$$PATH PKG_CONFIG_PATH=$(libdir)/pkgconfig $(bindir)/guile-config compile`
AM_LIBS   = `PATH=$(bindir)$(PATH_SEPARATOR)$$PATH PKG_CONFIG_PATH=$(libdir)/pkgconfig $(bindir)/guile-config link`

box/box: box/box.o
	-$(MKDIR_P) box
	$(CC) $< $(AM_LIBS) -o $@

box/box.o: box/box.c
	-$(MKDIR_P) box
	$(CC) $(AM_CFLAGS) -c $< -o $@

box-module/box: box-module/box.o
	-$(MKDIR_P) box-module
	$(CC) $< $(AM_LIBS) -o $@

box-module/box.o: box-module/box.c
	-$(MKDIR_P) box-module
	$(CC) $(AM_CFLAGS) -c $< -o $@

libbox.la: box-dynamic/box.lo
	$(top_builddir)/libtool --mode=link $(CC) $< $(AM_LIBS) -rpath $(libdir) -o $@

box-dynamic/box.lo: box-dynamic/box.c
	-$(MKDIR_P) box-dynamic
	$(top_builddir)/libtool --mode=compile $(CC) $(AM_CFLAGS) -c $< -o $@

libbox-module.la: box-dynamic-module/box.lo
	$(top_builddir)/libtool --mode=link $(CC) $< $(AM_LIBS) -rpath $(libdir) -o $@

box-dynamic-module/box.lo: box-dynamic-module/box.c
	-$(MKDIR_P) box-dynamic-module
	$(top_builddir)/libtool --mode=compile $(CC) $(AM_CFLAGS) -c $< -o $@

installcheck: box/box box-module/box libbox.la libbox-module.la
	LD_LIBRARY_PATH="$(libdir)$(PATH_SEPARATOR)$$LD_LIBRARY_PATH"		\
	  LTDL_LIBRARY_PATH="$(builddir)$(PATH_SEPARATOR)$$LTDL_LIBRARY_PATH"	\
	  GUILE_LOAD_PATH="$(abs_top_srcdir)$(PATH_SEPARATOR)$$GUILE_LOAD_PATH"	\
	  PATH="$(bindir)$(PATH_SEPARATOR)$$PATH"		\
	  GUILE_AUTO_COMPILE=0					\
	  srcdir="$(srcdir)"					\
	  $(srcdir)/check.test

CLEANFILES =					\
  box/box box/box.o				\
  box-module/box box-module/box.o

clean-local:
	$(top_builddir)/libtool --mode=clean rm -f	\
	  box-dynamic/box.lo libbox.la			\
	  box-dynamic-module/box.lo libbox-module.la


code:
							       -*- outline -*-

* Overview

This directory contains examples illustrating various aspects of Guile
programming.

If you plan writing Scheme programs, have a look at the `scripts'
directory.  To learn more about Guile modules, check out the `modules'
directory, and maybe the `box-module' and `box-dynamic-module'
directories, if you are into C programming or shared libraries,
respectively.  The `safe' directory contains examples for evaluation
Scheme code in controlled environments (sandboxing).  The directories
`box', `box-module', `box-dynamic' and `box-dynamic-module' are
interesting if you plan writing Guile extensions.

See the README files in the subdirectories for details.

* Included Examples

scripts             Examples for writing simple scripts in Guile Scheme.

box		    Example for extending Guile with a new data type.

box-module	    Similar to `box', but defines new procedures in a
		    named module.
box-dynamic	    Implements the box type in a dynamically loadable
		    library.
box-dynamic-module  Combination of `box-module' and `box-dynamic':
		    Implements the `box' type in a shared library and
		    defines the procedures in a Guile module.

modules		    Examples for writing and using Guile modules.

safe		    Examples for creating and using safe environments.

compat		    autoconf code for making a Guile extension
		    compatible with older versions of Guile.

path: examples/README


code:
							       -*- outline -*-

* Overview

This directory includes an example program for extending Guile with a
new (and even useful) data type, putting it into a shared library, so it
can be called from an unmodified guile interpreter. Further, the shared
library defines a new guile module.

* Build Instructions

To build the example, simply type

  make libbox-module

in this directory.

* The Box Data Type

A box is simply an object for storing one other object in.  It can be
used for passing parameters by reference, for example.  You simply
store an object into a box, pass it to another procedure which can
store a new object into it and thus return a value via the box.

** Usage

Box objects are created with `make-box', set with `box-set!' and
examined with `box-ref'.  Note that these procedures are placed in a
module called (box-module) and can thus only be accessed after using
this module.  See the following example session for usage details.

** The Module (box-module)

Extend your LD_LIBRARY_PATH variable (or equivalent) to include . and
.libs and make sure that your current working directory is the one
this file is contained in.

$ guile
guile> (use-modules (box-module))
guile> (define b (make-box))
guile> b
#<box #f>
guile> (box-set! b '(list of values))
guile> b
#<box (list of values)>
guile> (box-ref b)
(list of values)
guile> (quit)
$

** The Module (box-mixed)

The following example uses the module (box-mixed), also included in
this directory.  It uses the shared library libbox-module like the
module (box-module) above, but does not export the procedures from
that module.  It only implements some procedures for dealing with box
objects.

$ guile
guile> (use-modules (box-mixed))
guile> (define bl  (make-box-list 1 2 3))
guile> bl
(#<box 1> #<box 2> #<box 3>)
guile> (box-map 1+ bl)
(#<box 2> #<box 3> #<box 4>)
guile> (quit)
$

If you like this example so much that you want to have it available
for normal usage, install the dynamic libraries in the .libs directory
to the directory $(prefix)/lib and the scheme file `box-module.scm' in
a directory in your GUILE_LOAD_PATH.

path: examples/box-dynamic-module/README


code:
;;; examples/box-dynamic-module/box-mixed.scm -- Scheme module using some
;;;   functionality from the shared library libbox-module, but do not
;;;   export procedures from the module.

;;; Commentary:

;;; This is the Scheme module box-mixed.  It uses some functionality
;;; from the shared library libbox-module, but does not export it.

;;; Code:

;;; Author: Thomas Wawrzinek
;;; Date: 2001-06-08
;;; Changed: 2001-06-14 by martin, some commenting, cleanup and integration.

(define-module (box-mixed))

;; First, load the library.
;;
(load-extension "libbox-module" "scm_init_box")

;; Create a list of boxes, each containing one element from ARGS.
;;
(define (make-box-list . args)
  (map (lambda (el)
	 (let ((b (make-box)))
	   (box-set! b el) b))
       args))

;; Map the procedure FUNC over all elements of LST, which must be a
;; list of boxes.  The result is a list of freshly allocated boxes,
;; each containing the result of an application of FUNC.
(define (box-map func lst)
  (map (lambda (el)
	 (let ((b (make-box)))
	   (box-set! b (func (box-ref el)))
	   b))
       lst))

;; Export the procedures, so that they can be used by others.
;;
(export make-box-list box-map)

;;; End of file.


code:
;;; examples/box-dynamic-module/box-module.scm -- Scheme module exporting
;;;   some functionality from the shared library libbox-module.

;;; Commentary:

;;; This is the Scheme part of the dynamic library module (box-module).
;;; When you do a (use-modules (box-module)) in this directory,
;;; this file gets loaded and will load the compiled extension.

;;; Code:

;;; Author: Martin Grabmueller
;;; Date: 2001-06-06

(define-module (box-module))

;; First, load the library.
;;
(load-extension "libbox-module" "scm_init_box")

;; Then export the procedures which should be visible to module users.
;;
(export make-box box-ref box-set!)

;;; End of file.


code:
/* examples/box-dynamic-module/box.c
 *
 *	Copyright (C) 1998,2001, 2006 Free Software Foundation, Inc.
 *
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this software; see the file COPYING.LESSER.  If
 * not, write to the Free Software Foundation, Inc., 51 Franklin
 * Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

/* Include all needed declarations.  */
#include <libguile.h>

/* The type code for the newly created smob type will be stored into
   this variable.  It has the prefix `scm_tc16_' to make it usable
   with the SCM_VALIDATE_SMOB macro below.  */
static scm_t_bits scm_tc16_box;

/* This function is responsible for marking all SCM objects included
   in the smob.  */
static SCM
mark_box (SCM b)
{
  /* Since we have only one SCM object to protect, we simply return it
     and the caller will mark it.  */
  return SCM_CELL_OBJECT_1 (b);
}

/* Print a textual represenation of the smob to a given port.  */
static int
print_box (SCM b, SCM port, scm_print_state *pstate)
{
  SCM value = SCM_CELL_OBJECT_1 (b);

  scm_puts ("#<box ", port);
  scm_write (value, port);
  scm_puts (">", port);

  /* Non-zero means success.  */
  return 1;
}

/* This defines the primitve `make-box', which returns a new smob of
   type `box', initialized to `#f'.  */
static SCM
#define FUNC_NAME "make-box"
make_box (void)
{
  /* This macro creates the new objects, stores the value `#f' into it
     and returns it to the caller.  */
  SCM_RETURN_NEWSMOB (scm_tc16_box, SCM_BOOL_F);
}
#undef FUNC_NAME

/* This is the primitive `box-ref' which returns the object stored in
   the box.  */
static SCM
box_ref (SCM b)
#define FUNC_NAME "box-ref"
{
  /* First, we have to ensure that the user really gave us a box
     objects.  The macro SCM_VALIDATE_SMOB will do all what is needed.
     The parameters are interpreted as follows:

     1: The position of the checked variable in the parameter list.
     b: The passed parameter.
     box: Concatenated with the fixed prefix scm_tc16_, names the type
          code for the expected smob type.  */
  SCM_VALIDATE_SMOB (1, b, box);

  /* Fetch the object from the box and return it.  */
  return SCM_CELL_OBJECT_1 (b);
}
#undef FUNC_NAME

/* Primitive which stores an arbitrary value into a box.  */
static SCM
box_set_x (SCM b, SCM value)
#define FUNC_NAME "box-set!"
{
  SCM_VALIDATE_SMOB (1, b, box);

  /* Set the cell number 1 of the smob to the given value.  */
  SCM_SET_CELL_OBJECT_1 (b, value);

  /* When this constant is returned, the REPL will not print the
     returned value.  All procedures in Guile which are documented as
     returning `and unspecified value' actually return this value.  */
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

/* This is the function which must be given to `load-extension' as the
   second argument.  In this example, the Scheme file box-module.scm
   (or box-mixed.scm) is responsible for doing the load-extension
   call.  The Scheme modules are also responsible for placing the
   procedure definitions in the correct module. */
void
scm_init_box ()
{
  scm_tc16_box = scm_make_smob_type ("box", 0);
  scm_set_smob_mark (scm_tc16_box, mark_box);
  scm_set_smob_print (scm_tc16_box, print_box);

  scm_c_define_gsubr ("make-box", 0, 0, 0, make_box);
  scm_c_define_gsubr ("box-set!", 2, 0, 0, box_set_x);
  scm_c_define_gsubr ("box-ref", 1, 0, 0, box_ref);
}

/* End of file.  */


code:
							       -*- outline -*-

* Overview

This directory includes an example program for extending Guile with a
new (and even useful) data type, putting it into a shared library, so it
can be called from an unmodified guile interpreter.

* Build Instructions

To build the example, simply type

  make libbox

in this directory.

* The Box Data Type

A box is simply an object for storing one other object in.  It can be
used for passing parameters by reference, for example.  You simply
store an object into a box, pass it to another procedure which can
store a new object into it and thus return a value via the box.

** Usage

Box objects are created with `make-box', set with `box-set!' and
examined with `box-ref'.  Note that these procedures are placed in a
module called (box-module) and can thus only be accessed after using
this module.  See the following example session for usage details:

Extend your LD_LIBRARY_PATH variable (or equivalent) to include . and
.libs

** Example Session

$ guile
guile> (load-extension "libbox" "scm_init_box")
guile> (define b (make-box))
guile> b
#<box #f>
guile> (box-set! b '(list of values))
guile> b
#<box (list of values)>
guile> (box-ref b)
(list of values)
guile> (quit)
$

* Module Installation

If you like this example so much that you want to have it available
for normal usage, install the dynamic libraries in the .libs directory
to the directory $(prefix)/lib

path: examples/box-dynamic/README


code:
/* examples/box-dynamic/box.c
 *
 *	Copyright (C) 1998,2001, 2006 Free Software Foundation, Inc.
 *
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this software; see the file COPYING.LESSER.  If
 * not, write to the Free Software Foundation, Inc., 51 Franklin
 * Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

/* Include all needed declarations.  */
#include <libguile.h>

/* The type code for the newly created smob type will be stored into
   this variable.  It has the prefix `scm_tc16_' to make it usable
   with the SCM_VALIDATE_SMOB macro below.  */
static scm_t_bits scm_tc16_box;

/* This function is responsible for marking all SCM objects included
   in the smob.  */
static SCM
mark_box (SCM b)
{
  /* Since we have only one SCM object to protect, we simply return it
     and the caller will mark it.  */
  return SCM_CELL_OBJECT_1 (b);
}

/* Print a textual represenation of the smob to a given port.  */
static int
print_box (SCM b, SCM port, scm_print_state *pstate)
{
  SCM value = SCM_CELL_OBJECT_1 (b);

  scm_puts ("#<box ", port);
  scm_write (value, port);
  scm_puts (">", port);

  /* Non-zero means success.  */
  return 1;
}

/* This defines the primitve `make-box', which returns a new smob of
   type `box', initialized to `#f'.  */
static SCM
#define FUNC_NAME "make-box"
make_box (void)
{
  /* This macro creates the new objects, stores the value `#f' into it
     and returns it to the caller.  */
  SCM_RETURN_NEWSMOB (scm_tc16_box, SCM_BOOL_F);
}
#undef FUNC_NAME

/* This is the primitive `box-ref' which returns the object stored in
   the box.  */
static SCM
box_ref (SCM b)
#define FUNC_NAME "box-ref"
{
  /* First, we have to ensure that the user really gave us a box
     objects.  The macro SCM_VALIDATE_SMOB will do all what is needed.
     The parameters are interpreted as follows:

     1: The position of the checked variable in the parameter list.
     b: The passed parameter.
     box: Concatenated with the fixed prefix scm_tc16_, names the type
          code for the expected smob type.  */
  SCM_VALIDATE_SMOB (1, b, box);

  /* Fetch the object from the box and return it.  */
  return SCM_CELL_OBJECT_1 (b);
}
#undef FUNC_NAME

/* Primitive which stores an arbitrary value into a box.  */
static SCM
box_set_x (SCM b, SCM value)
#define FUNC_NAME "box-set!"
{
  SCM_VALIDATE_SMOB (1, b, box);

  /* Set the cell number 1 of the smob to the given value.  */
  SCM_SET_CELL_OBJECT_1 (b, value);

  /* When this constant is returned, the REPL will not print the
     returned value.  All procedures in Guile which are documented as
     returning `and unspecified value' actually return this value.  */
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

/* Create and initialize the new smob type, and register the
   primitives with the interpreter library.

   To be called with (load-extension "libbox" "scm_init_box")
   from a script.
*/
void
scm_init_box ()
{
  scm_tc16_box = scm_make_smob_type ("box", 0);
  scm_set_smob_mark (scm_tc16_box, mark_box);
  scm_set_smob_print (scm_tc16_box, print_box);

  scm_c_define_gsubr ("make-box", 0, 0, 0, make_box);
  scm_c_define_gsubr ("box-set!", 2, 0, 0, box_set_x);
  scm_c_define_gsubr ("box-ref", 1, 0, 0, box_ref);
}

/* End of file.  */


code:
							       -*- outline -*-

* Overview

This directory includes an example program for extending Guile with a
new (and even useful) data type.

The `box' program created by this example is nearly identical to the
one produced in directory ../box, with one (important) difference: The
interpreter in this directory will place all defined primitive
procedures in a module called (box-module).  That means that this
module must be used before the primitives can be accessed.

* Build Instructions

To build the example, simply type

  make box

in this directory.

The resulting `box' program is a Guile interpreter which has one
additional data type called `box'.

* The Box Data Type

A box is simply an object for storing one other object in.  It can be
used for passing parameters by reference, for example.  You simply
store an object into a box, pass it to another procedure which can
store a new object into it and thus return a value via the box.

** Usage

Box objects are created with `make-box', set with `box-set!' and
examined with `box-ref'.  Note that these procedures are placed in a
module called (box-module) and can thus only be accessed after using
this module.  See the following example session for usage details:

** Example Session

$ ./box
guile> (use-modules (box-module))
guile> (define b (make-box))
guile> b
#<box #f>
guile> (box-set! b '(list of values))
guile> b
#<box (list of values)>
guile> (box-ref b)
(list of values)
guile> (quit)
$

path: examples/box-module/README


code:
/* examples/box-module/box.c
 *
 *	Copyright (C) 1998,2001, 2006 Free Software Foundation, Inc.
 *
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this software; see the file COPYING.LESSER.  If
 * not, write to the Free Software Foundation, Inc., 51 Franklin
 * Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

/* Include all needed declarations.  */
#include <libguile.h>

/* The type code for the newly created smob type will be stored into
   this variable.  It has the prefix `scm_tc16_' to make it usable
   with the SCM_VALIDATE_SMOB macro below.  */
static scm_t_bits scm_tc16_box;

/* This function is responsible for marking all SCM objects included
   in the smob.  */
static SCM
mark_box (SCM b)
{
  /* Since we have only one SCM object to protect, we simply return it
     and the caller will mark it.  */
  return SCM_CELL_OBJECT_1 (b);
}

/* Print a textual represenation of the smob to a given port.  */
static int
print_box (SCM b, SCM port, scm_print_state *pstate)
{
  SCM value = SCM_CELL_OBJECT_1 (b);

  scm_puts ("#<box ", port);
  scm_write (value, port);
  scm_puts (">", port);

  /* Non-zero means success.  */
  return 1;
}

/* This defines the primitve `make-box', which returns a new smob of
   type `box', initialized to `#f'.  */
static SCM
#define FUNC_NAME "make-box"
make_box (void)
{
  /* This macro creates the new objects, stores the value `#f' into it
     and returns it to the caller.  */
  SCM_RETURN_NEWSMOB (scm_tc16_box, SCM_BOOL_F);
}
#undef FUNC_NAME

/* This is the primitive `box-ref' which returns the object stored in
   the box.  */
static SCM
box_ref (SCM b)
#define FUNC_NAME "box-ref"
{
  /* First, we have to ensure that the user really gave us a box
     objects.  The macro SCM_VALIDATE_SMOB will do all what is needed.
     The parameters are interpreted as follows:

     1: The position of the checked variable in the parameter list.
     b: The passed parameter.
     box: Concatenated with the fixed prefix scm_tc16_, names the type
          code for the expected smob type.  */
  SCM_VALIDATE_SMOB (1, b, box);

  /* Fetch the object from the box and return it.  */
  return SCM_CELL_OBJECT_1 (b);
}
#undef FUNC_NAME

/* Primitive which stores an arbitrary value into a box.  */
static SCM
box_set_x (SCM b, SCM value)
#define FUNC_NAME "box-set!"
{
  SCM_VALIDATE_SMOB (1, b, box);

  /* Set the cell number 1 of the smob to the given value.  */
  SCM_SET_CELL_OBJECT_1 (b, value);

  /* When this constant is returned, the REPL will not print the
     returned value.  All procedures in Guile which are documented as
     returning `and unspecified value' actually return this value.  */
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

/* Create and initialize the new smob type, and register the
   primitives withe the interpreter library.

   This function must be declared a bit different from the example in
   the ../box directory, because it will be called by
   `scm_c_define_module', called from below.  */
static void
init_box_type (void * unused)
{
  scm_tc16_box = scm_make_smob_type ("box", 0);
  scm_set_smob_mark (scm_tc16_box, mark_box);
  scm_set_smob_print (scm_tc16_box, print_box);

  scm_c_define_gsubr ("make-box", 0, 0, 0, make_box);
  scm_c_define_gsubr ("box-set!", 2, 0, 0, box_set_x);
  scm_c_define_gsubr ("box-ref", 1, 0, 0, box_ref);

  /* This is new too: Since the procedures are now in a module, we
     have to explicitly export them before they can be used.  */
  scm_c_export ("make-box", "box-set!", "box-ref", NULL);
}

/* This is the function which gets called by scm_boot_guile after the
   Guile library is completely initialized.  */
static void
inner_main (void *closure, int argc, char **argv)
{
  /* Unlike the example in ../box, init_box_type is not called
     directly, but by scm_c_define_module, which will create a module
     named (box-module) and make this module current while called
     init_box_type, thus placing the definitions into that module.  */
  scm_c_define_module ("box-module", init_box_type, NULL);

  /* ... then we start a shell, in which the box data type can be
     used (after using the module (box-module)).  */
  scm_shell (argc, argv);
}

/* Main program.  */
int
main (int argc, char **argv)
{
  /* Initialize Guile, then call `inner_main' with the arguments 0,
     argc and argv.  */
  scm_boot_guile (argc, argv, inner_main, 0);
  return 0; /* Never reached.  */
}

/* End of file.  */


code:
							       -*- outline -*-

* Overview

This directory includes an example program for extending Guile with a
new (and even useful) data type.

* Build Instructions

To build the example, simply type

  make box

in this directory.

The resulting `box' program is a Guile interpreter which has one
additional data type called `box'.

* The Box Data Type

A box is simply an object for storing one other object in.  It can be
used for passing parameters by reference, for example.  You simply
store an object into a box, pass it to another procedure which can
store a new object into it and thus return a value via the box.

** Usage

Box objects are created with `make-box', set with `box-set!' and
examined with `box-ref'.  See the following example session for usage
details:

** Example Session

$ ./box
guile> (define b (make-box))
guile> b
#<box #f>
guile> (box-set! b '(list of values))
guile> b
#<box (list of values)>
guile> (box-ref b)
(list of values)
guile> (quit)
$

path: examples/box/README


code:
/* examples/box/box.c
 *
 *	Copyright (C) 1998,2001, 2006 Free Software Foundation, Inc.
 *
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this software; see the file COPYING.LESSER.  If
 * not, write to the Free Software Foundation, Inc., 51 Franklin
 * Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

/* Include all needed declarations.  */
#include <libguile.h>

/* The type code for the newly created smob type will be stored into
   this variable.  It has the prefix `scm_tc16_' to make it usable
   with the SCM_VALIDATE_SMOB macro below.  */
static scm_t_bits scm_tc16_box;

/* This function is responsible for marking all SCM objects included
   in the smob.  */
static SCM
mark_box (SCM b)
{
  /* Since we have only one SCM object to protect, we simply return it
     and the caller will mark it.  */
  return SCM_CELL_OBJECT_1 (b);
}

/* Print a textual represenation of the smob to a given port.  */
static int
print_box (SCM b, SCM port, scm_print_state *pstate)
{
  SCM value = SCM_CELL_OBJECT_1 (b);

  scm_puts ("#<box ", port);
  scm_write (value, port);
  scm_puts (">", port);

  /* Non-zero means success.  */
  return 1;
}

/* This defines the primitve `make-box', which returns a new smob of
   type `box', initialized to `#f'.  */
static SCM
#define FUNC_NAME "make-box"
make_box (void)
{
  /* This macro creates the new objects, stores the value `#f' into it
     and returns it to the caller.  */
  SCM_RETURN_NEWSMOB (scm_tc16_box, SCM_BOOL_F);
}
#undef FUNC_NAME

/* This is the primitive `box-ref' which returns the object stored in
   the box.  */
static SCM
box_ref (SCM b)
#define FUNC_NAME "box-ref"
{
  /* First, we have to ensure that the user really gave us a box
     objects.  The macro SCM_VALIDATE_SMOB will do all what is needed.
     The parameters are interpreted as follows:

     1: The position of the checked variable in the parameter list.
     b: The passed parameter.
     box: Concatenated with the fixed prefix scm_tc16_, names the type
          code for the expected smob type.  */
  SCM_VALIDATE_SMOB (1, b, box);

  /* Fetch the object from the box and return it.  */
  return SCM_CELL_OBJECT_1 (b);
}
#undef FUNC_NAME

/* Primitive which stores an arbitrary value into a box.  */
static SCM
box_set_x (SCM b, SCM value)
#define FUNC_NAME "box-set!"
{
  SCM_VALIDATE_SMOB (1, b, box);

  /* Set the cell number 1 of the smob to the given value.  */
  SCM_SET_CELL_OBJECT_1 (b, value);

  /* When this constant is returned, the REPL will not print the
     returned value.  All procedures in Guile which are documented as
     returning `and unspecified value' actually return this value.  */
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

/* Create and initialize the new smob type, and register the
   primitives withe the interpreter library.  */
static void
init_box_type (void)
{
  scm_tc16_box = scm_make_smob_type ("box", 0);
  scm_set_smob_mark (scm_tc16_box, mark_box);
  scm_set_smob_print (scm_tc16_box, print_box);

  scm_c_define_gsubr ("make-box", 0, 0, 0, make_box);
  scm_c_define_gsubr ("box-set!", 2, 0, 0, box_set_x);
  scm_c_define_gsubr ("box-ref", 1, 0, 0, box_ref);
}

/* This is the function which gets called by scm_boot_guile after the
   Guile library is completely initialized.  */
static void
inner_main (void *closure, int argc, char **argv)
{
  /* First, we create our data type... */
  init_box_type ();
  /* ... then we start a shell, in which the box data type can be
     used.  */
  scm_shell (argc, argv);
}

/* Main program.  */
int
main (int argc, char **argv)
{
  /* Initialize Guile, then call `inner_main' with the arguments 0,
     argc and argv.  */
  scm_boot_guile (argc, argv, inner_main, 0);
  return 0; /* Never reached.  */
}

/* End of file.  */


code:
#!/bin/sh

# must be run from this directory
guile=${GUILE-../libguile/guile}
if [ -x $guile ] ; then
    :
else
    echo could not find guile interpreter.
    echo '(are you running this script from' `dirname $0` '?)'
    echo GUILE env var: ${GUILE-not set}
    exit 1
fi

if test "X$srcdir" = X; then
    srcdir=.
fi

set -e

#
# simple-hello.scm
#
$guile -s $srcdir/scripts/simple-hello.scm > TMP
cat <<EOF | diff -u - TMP
Hello, World!
EOF
rm -f TMP

#
# hello
#
$guile -s $srcdir/scripts/hello > TMP
echo "Hello, World!" | diff -u - TMP
rm -f TMP

$guile -s $srcdir/scripts/hello --version > TMP
echo "hello 0.0.1" | diff -u - TMP
rm -f TMP

$guile -s $srcdir/scripts/hello --help > TMP
cat <<EOF | diff -u - TMP
Usage: hello [options...]
  --help, -h           Show this usage information
  --version, -v        Show version information
EOF
rm -f TMP

#
# fact
#
case `$guile -s $srcdir/scripts/fact 5` in 120) ;; *) echo $0: error: fact 5 ;; esac

#
# ./box/box test #1
#
./box/box -c '(let ((b (make-box))) (display b) (newline))' > TMP
cat <<EOF | diff -u - TMP
#<box #f>
EOF
rm -f TMP

#
# ./box/box test #2
#
./box/box -c '(let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline))' > TMP
cat <<EOF | diff -u - TMP
#<box #f>
#<box 1>
EOF
rm -f TMP

#
# ./box/box test #3
#
./box/box -c '(let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline) (display (box-ref b)) (newline))' > TMP
cat <<EOF | diff -u - TMP
#<box #f>
#<box 1>
1
EOF
rm -f TMP

#
# ./box-module/box test #1
#
./box-module/box -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline)))' > TMP
cat <<EOF | diff -u - TMP
#<box #f>
EOF
rm -f TMP

#
# ./box-module/box test #2
#
./box-module/box -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline)))' > TMP
cat <<EOF | diff -u - TMP
#<box #f>
#<box 1>
EOF
rm -f TMP

#
# ./box-module/box test #3
#
./box-module/box -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline) (display (box-ref b)) (newline)))' > TMP
cat <<EOF | diff -u - TMP
#<box #f>
#<box 1>
1
EOF
rm -f TMP

#
# ./box-dynamic/box test #1
#
$guile -c '(begin (load-extension "libbox" "scm_init_box") (let ((b (make-box))) (display b) (newline)))' > TMP
cat <<EOF | diff -u - TMP
#<box #f>
EOF
rm -f TMP

#
# ./box-dynamic/box test #2
#
$guile -c '(begin (load-extension "libbox" "scm_init_box") (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline)))' > TMP
cat <<EOF | diff -u - TMP
#<box #f>
#<box 1>
EOF
rm -f TMP

#
# ./box-dynamic/box test #3
#
$guile -c '(begin (load-extension "libbox" "scm_init_box") (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline) (display (box-ref b)) (newline)))' > TMP
cat <<EOF | diff -u - TMP
#<box #f>
#<box 1>
1
EOF
rm -f TMP

#
# ./box-dynamic-module/box test #1
#
$guile -L $srcdir/box-dynamic-module \
  -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline)))' > TMP
cat <<EOF | diff -u - TMP
#<box #f>
EOF
rm -f TMP

#
# ./box-dynamic-module/box test #2
#
$guile -L $srcdir/box-dynamic-module \
  -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline)))' > TMP
cat <<EOF | diff -u - TMP
#<box #f>
#<box 1>
EOF
rm -f TMP

#
# ./box-dynamic-module/box test #3
#
$guile -L $srcdir/box-dynamic-module \
  -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline) (display (box-ref b)) (newline)))' > TMP
cat <<EOF | diff -u - TMP
#<box #f>
#<box 1>
1
EOF
rm -f TMP

#
# ./box-dynamic-module/box test #4
#
$guile -L $srcdir/box-dynamic-module \
  -c '(begin (use-modules (box-mixed)) (let ((b (make-box-list 1 2 3))) (display b) (newline) (display (box-map 1+ b)) (newline)))' > TMP
cat <<EOF | diff -u - TMP
(#<box 1> #<box 2> #<box 3>)
(#<box 2> #<box 3> #<box 4>)
EOF
rm -f TMP

#
# ./main test
#
$guile -L $srcdir/modules -s $srcdir/modules/main > TMP
cat <<EOF | diff -u - TMP
module-0 foo
module-0 bar
module-1 foo
module-1 bar
module-2 braz
module-2 braz
module-2 foo
EOF
rm -f TMP

#
# ./safe untrusted.scm
#
$guile -s $srcdir/safe/safe $srcdir/safe/untrusted.scm > TMP
cat <<EOF | diff -u - TMP
1
1
2
6
24
120
720
5040
40320
362880
3628800
EOF
rm -f TMP

#
# ./safe evil.scm
#
$guile -s $srcdir/safe/safe $srcdir/safe/evil.scm > TMP
cat <<EOF | diff -u - TMP
** Exception: (unbound-variable #f "Unbound variable: ~S" (open-input-file) #f)
EOF
rm -f TMP

# check.test ends here


code:
AC_DEFUN([GUILE_COMPAT],
 [guile_compat_save_CFLAGS="$CFLAGS"
  guile_compat_save_LIBS="$LIBS"
  CFLAGS="$GUILE_CFLAGS"
  LIBS="$GUILE_LDFLAGS"
  AC_CHECK_FUNCS([scm_c_define_module scm_c_read_string scm_gc_protect_object scm_list_1 scm_c_register_extension scm_make_real scm_num2double scm_c_define_gsubr])
  AC_MSG_CHECKING(for scm_t_bits)
  AC_CACHE_VAL(ac_cv_have_scm_t_bits,
               [AC_TRY_COMPILE([#include <libguile.h>],
                               [scm_t_bits a;],
                               ac_cv_have_scm_t_bits=yes,
                               ac_cv_have_scm_t_bits=no)])
  AC_MSG_RESULT($ac_cv_have_scm_t_bits)
  if test $ac_cv_have_scm_t_bits = yes; then
    AC_DEFINE([HAVE_SCM_T_BITS])
  fi
  LIBS="$guile_compat_save_LIBS"
  CFLAGS="$guile_compat_save_CFLAGS"])


code:
/* classes: h_files */

#ifndef COMPATH
#define COMPATH
/*	Copyright (C) 2001, 2002, 2006, 2008 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#ifndef SCM_GC8MARKP
#  define SCM_GC8MARKP(X) SCM_GC_MARK_P(X)
#  define SCM_SETGC8MARK(X) SCM_SET_GC_MARK(X)
#endif

#ifndef SCM_GC_MARK_P
#  define SCM_GC_MARK_P(X) SCM_GCMARKP(X)
#  define SCM_SET_GC_MARK(X) SCM_SETGCMARK(X)
#endif

#ifndef SCM_ARRAY_FLAG_CONTIGUOUS
#  define SCM_ARRAY_FLAG_CONTIGUOUS SCM_ARRAY_CONTIGUOUS
#endif

#ifndef HAVE_SCM_T_BITS
typedef scm_bits_t scm_t_bits;
typedef scm_array scm_t_array;
typedef scm_array_dim scm_t_array_dim;
typedef scm_mutex_t scm_t_mutex;
typedef scm_cond_t scm_t_cond;
typedef scm_key_t scm_t_key;
typedef scm_catch_body_t scm_t_catch_body;
typedef scm_catch_handler_t scm_t_catch_handler;
typedef scm_rstate scm_t_rstate;
typedef scm_port scm_t_port;
typedef scm_fport scm_t_fport;
#endif

#ifndef SCM_VALIDATE_DOUBLE_COPY
#define SCM_VALIDATE_DOUBLE_COPY SCM_VALIDATE_NUMBER_COPY
#endif

#ifndef HAVE_SCM_C_DEFINE_MODULE
#define scm_c_define_module(NAME,INIT,DATA) \
  scm_make_module (scm_read_0str ("(" NAME ")"))
#endif

#ifndef SCM_MAKE_CHAR
#define SCM_MAKE_CHAR SCM_MAKICHR
#define SCM_CHAR SCM_ICHR
#define SCM_CHARP SCM_ICHRP
#endif

#ifndef SCM_ROSTRINGP
#define SCM_ROSTRINGP(x) (SCM_STRINGP (x) || SCM_SYMBOLP (x))
#define SCM_RWSTRINGP(x) SCM_STRINGP (x)
#define SCM_ROCHARS(x) \
  (SCM_STRINGP (x) ? SCM_STRING_CHARS (x) : SCM_SYMBOL_CHARS (x))
#define SCM_ROLENGTH(x) \
  (SCM_STRINGP (x) ? SCM_STRING_LENGTH (x) : SCM_SYMBOL_LENGTH (x))
#endif

#ifndef SCM_STRING_COERCE_0TERMINATION_X
#ifdef SCM_COERCE_SUBSTR
#define SCM_STRING_COERCE_0TERMINATION_X SCM_COERCE_SUBSTR
#else
#define SCM_STRING_COERCE_0TERMINATION_X(x) (x)
#endif
#endif

#ifndef HAVE_SCM_C_READ_STRING
#define scm_c_read_string scm_read_0str
#define scm_c_eval_string scm_eval_0str
#define scm_str2symbol(X) SCM_CAR (scm_intern0 (X))
#define scm_mem2string(X, Y) scm_makfromstr ((X), (Y), 0)
#endif

#ifndef HAVE_SCM_MAKE_REAL
#define scm_make_real(X) scm_makdbl ((X), 0.0)
#endif

#ifdef HAVE_SCM_NUM2DOUBLE
#define scm_real2double scm_num2double
#define SCM_REAL2DOUBLE SCM_NUM2DOUBLE
#else
#define scm_real2double(X, POS, WHERE) scm_num2dbl ((X), (WHERE))
#define SCM_REAL2DOUBLE(X, POS) scm_num2dbl ((X), FUNC_NAME)
#endif

#ifndef SCM_VALIDATE_DOUBLE_DEF_COPY
#define SCM_VALIDATE_DOUBLE_DEF_COPY SCM_VALIDATE_NUMBER_DEF_COPY
#endif

#ifndef HAVE_SCM_GC_PROTECT_OBJECT
#define scm_gc_protect_object scm_protect_object
#endif

#ifndef HAVE_SCM_C_DEFINE_GSUBR
#define scm_c_define_gsubr scm_make_gsubr
#endif

#ifndef SCM_STRING_CHARS
#define SCM_STRING_CHARS SCM_CHARS
#define SCM_STRING_UCHARS SCM_UCHARS
#define SCM_STRING_LENGTH SCM_LENGTH
#endif

#ifndef SCM_SUBSTRP
#define SCM_SUBSTRP(X) 0
#endif

#ifndef SCM_VECTOR_LENGTH
#define SCM_VECTOR_LENGTH SCM_LENGTH
#define SCM_UVECTOR_LENGTH SCM_LENGTH
#endif

#ifndef SCM_SET_VECTOR_LENGTH
#define SCM_SET_VECTOR_LENGTH SCM_SETLENGTH
#define SCM_SET_UVECTOR_LENGTH SCM_SETLENGTH
#endif

#ifndef SCM_VECTOR_BASE
#define SCM_VECTOR_BASE SCM_CHARS
#define SCM_UVECTOR_BASE SCM_CHARS
#endif

#ifndef SCM_SET_VECTOR_BASE
#define SCM_SET_VECTOR_BASE SCM_SETCHARS
#define SCM_SET_UVECTOR_BASE SCM_SETCHARS
#endif

#ifndef SCM_UVECTOR_MAX_LENGTH
#define SCM_UVECTOR_MAX_LENGTH SCM_LENGTH_MAX
#endif

#ifndef HAVE_SCM_LIST_1
#define scm_list_1 SCM_LIST1
#define scm_list_2 SCM_LIST2
#define scm_list_3 SCM_LIST3
#define scm_list_4 SCM_LIST4
#define scm_list_5 SCM_LIST5
#define scm_list_n scm_listify
#endif

#ifndef SCM_SYMBOL_CHARS
#define SCM_SYMBOL_CHARS SCM_CHARS
#endif

#endif /* COMPATH */


code:
### BEGIN compatibility checks ###

AC_CHECK_FUNCS(scm_c_define_module scm_c_read_string scm_gc_protect_object scm_list_1)

AC_MSG_CHECKING(for scm_t_bits)
AC_CACHE_VAL(ac_cv_have_scm_t_bits,
[AC_TRY_COMPILE([#include <libguile.h>],
[scm_t_bits a;],
ac_cv_have_scm_t_bits=yes, ac_cv_have_scm_t_bits=no)])
AC_MSG_RESULT($ac_cv_have_scm_t_bits)
if test $ac_cv_have_scm_t_bits = yes; then
  AC_DEFINE(HAVE_SCM_T_BITS)
fi

### END compatibility checks ###


code:
							       -*- outline -*-

* Overview

This directory includes examples which show how to write and use Guile
modules in Scheme programs.

The descriptions below assume that you have a working copy of Guile
installed and available with the standard installation prefix
`/usr/local'.

* Included Examples

** main

  The main program, which uses the modules described below to perform
  some actions.  Module usage and selective importing as well as
  renaming is demonstrated here.n

  $ ./main

  or

  guile -s main

** module-0.scm, module-1.scm, module-2.scm

  Two modules which export several procedure, some of which have the
  same names (so that renaming/selection is required for proper
  importing).

path: examples/modules/README


code:
#! /usr/local/bin/guile -s
!#
;;; examples/modules/main -- Module system demo.

;;; Commentary:

;;; The main demo program for the modules subdirectory.
;;;
;;; This program shows how all the new fancy module import features
;;; are to be used.

;;; Author: Martin Grabmueller
;;; Date: 2001-05-29

;;; Code:

(define-module (main)
  ;; The module 0 is imported completely.
  ;;
  :use-module (module-0)

  ;; Module 1 is imported completely, too, but the procedure names are
  ;; prefixed with the module name.
  ;;
  :use-module ((module-1) :renamer (symbol-prefix-proc 'module-1:))

  ;; From module 2, only the procedure `braz' is imported, so that the
  ;; procedures `foo' and `bar' also exported by that module don't
  ;; clash with the definitions of module 0.
  ;;
  :use-module ((module-2) :select (braz))

  ;; Import the bindings from module 2 again, now renaming them by
  ;; explicitly mentioning the original and new names.
  ;;
  :use-module ((module-2) :select ((braz . m-2:braz) (foo . m-2:foo))))

;;
;; Now call the various imported procedures.
;;

(foo)
(bar)
(module-1:foo)
(module-1:bar)
(braz)
(m-2:braz)
(m-2:foo)

;; Local variables:
;; mode: scheme
;; End:

path: examples/modules/main


code:
;;; examples/modules/module-0.scm -- Module system demo.

;;; Commentary:

;;; Module 0 of the module demo program.

;;; Author: Martin Grabmueller
;;; Date: 2001-05-29

;;; Code:

(define-module (module-0))

(export foo bar)

(define (foo)
  (display "module-0 foo")
  (newline))

(define (bar)
  (display "module-0 bar")
  (newline))

;;; End of file.


code:
;;; examples/modules/module-1.scm -- Module system demo.

;;; Commentary:

;;; Module 1 of the module demo program.

;;; Author: Martin Grabmueller
;;; Date: 2001-05-29

;;; Code:

(define-module (module-1))

(export foo bar)

(define (foo)
  (display "module-1 foo")
  (newline))

(define (bar)
  (display "module-1 bar")
  (newline))

;;; End of file.


code:
;;; examples/modules/module-2.scm -- Module system demo.

;;; Commentary:

;;; Module 2 of the module demo program.

;;; Author: Martin Grabmueller
;;; Date: 2001-05-29

;;; Code:

(define-module (module-2))

(export foo bar braz)

(define (foo)
  (display "module-2 foo")
  (newline))

(define (bar)
  (display "module-2 bar")
  (newline))

(define (braz)
  (display "module-2 braz")
  (newline))

;;; End of file.


code:
							       -*- outline -*-

* Overview

This directory includes examples which show how to create and use safe
environments for safe (sand-boxed) execution of Scheme programs.

*Note* that the files in this directory are only suitable for
 demonstration purposes, if you have to implement safe evaluation
 mechanisms in important environments, you will have to do more than
 shown here -- for example disabling input/output operations.

The descriptions below assume that you have a working copy of Guile
installed and available with the standard installation prefix
`/usr/local'.

* Included Examples

** safe

  The main program, which executes the Scheme code in a file given on
  the command line in a safe environment.  The following command will
  do that with the file `untrusted.scm' (see below.)

  $ ./safe untrusted.scm

  or

  guile -s safe untrusted.scm

** untrusted.scm

  This file contains some Scheme code, which will be executed in a
  safe environment by the `safe' script.

** evil.scm

  This file also contains Scheme code, but it tries to do evil things.
  Evaluating this with the `safe' script will abort on those evil
  actions.

path: examples/safe/README


code:
;;; examples/safe/evil.scm -- Evil Scheme file to be run in a safe
;;; environment.

;;; Commentary:

;;; This is an example file to be evaluated by the `safe' program in
;;; this directory.  This program, unlike the `untrusted.scm' (which
;;; is untrusted, but a really nice fellow though), tries to do evil
;;; things and will thus break in a safe environment.
;;;
;;; *Note* that the files in this directory are only suitable for
;;; demonstration purposes, if you have to implement safe evaluation
;;; mechanisms in important environments, you will have to do more
;;; than shown here -- for example disabling input/output operations.

;;; Author: Martin Grabmueller
;;; Date: 2001-05-30

;;; Code:

(define passwd (open-input-file "/etc/passwd"))

(let lp ((ch (read-char passwd)))
  (if (not (eof-object? ch))
    (lp (read-char passwd))))

;;; End of file.


code:
#! /usr/local/bin/guile -s
!#
;;; examples/safe/safe -- Example for safe (sand-boxed) evaluation.

;;; Commentary:

;;; This is a demo program for evaluating arbitrary (untrusted) Scheme
;;; code in a controlled, safe environment.  Evaluation in safe
;;; environments restricts the evaluated code's access to some given
;;; primitives, which are considered `safe', that means which cannot
;;; do any harm to the world outside of Guile (creating/deleting files
;;; etc.)
;;;
;;; *Note* that the files in this directory are only suitable for
;;; demonstration purposes, if you have to implement safe evaluation
;;; mechanisms in important environments, you will have to do more
;;; than shown here -- for example disabling input/output operations.

;;; Author: Martin Grabmueller
;;; Date: 2001-05-30

;;; Code:

;; Safe module creation is implemented in this module:
;;
(use-modules (ice-9 safe))

;; This is the main program.  It expects one parameter in the format
;; returned by (command-line) and expects that exactly one file name
;; is passed in this list (after the script name, which is passed as
;; the 0th parameter.)
;;
;; The given file is opened for reading, one expression after the
;; other is read and evaluated in a safe environment.  All exceptions
;; caused by this evaluation are caught and printed out.
;;
(define (main cmd-line)

  ;; Internal definition of the procedure which prints usage
  ;; information.
  ;;
  (define (display-help)
    (display "Usage: safe FILENAME")
    (newline)
    (quit 1))

  ;; Check that we received exactly one command line argument after
  ;; the script name
  ;;
  (if (not (= (length cmd-line) 2))
    (display-help)
    (let ((port (open-input-file (cadr cmd-line)))

	  ;; Create the safe module.
	  (safe-module (make-safe-module)))

      ;; Read one expression a time.
      (let lp ((expr (read port)))
	;; End of file? -> Return.
	(if (eof-object? expr)
	  #t
	  (catch #t
	    (lambda ()
	      ;; Evaluate the expression in the safe environment.
	      (eval expr safe-module)
	      ;; ... and read the next expression if no error occured.
	      (lp (read port)))

	    ;; Handle exceptions.  This procedure will be called when an
	    ;; error occurs while evaluating the expression.  It just
	    ;; prints out a message telling so and returns from the
	    ;; evaluation loop, thus terminating the program.
	    ;;
	    (lambda args
	      (display "** Exception: ")
	      (write args)
	      (newline))))))))

;; Start the main program.
;;
(main (command-line))

;; Local variables:
;; mode: scheme
;; End:

path: examples/safe/safe


code:
;;; examples/safe/untrusted.scm -- Scheme file to be run in a safe
;;; environment.

;;; Commentary:

;;; This is an example file to be evaluated by the `safe' program in
;;; this directory.
;;;
;;; *Note* that the files in this directory are only suitable for
;;; demonstration purposes, if you have to implement safe evaluation
;;; mechanisms in important environments, you will have to do more
;;; than shown here -- for example disabling input/output operations.

;;; Author: Martin Grabmueller
;;; Date: 2001-05-30

;;; Code:

;; fact -- the everlasting factorial function...
;;
(define (fact n)
  (if (< n 2)
    1
    (* n (fact (- n 1)))))

;; Display the factorial of 0..9 to the terminal.
;;
(do ((x 0 (+ x 1)))
    ((= x 11))
  (display (fact x))
  (newline))

;;; End of file.


code:
							       -*- outline -*-

* Overview

This directory includes examples which show how to write scripts using
Guile.

The descriptions below assume that you have a working copy of Guile
installed and available with the standard installation prefix
`/usr/local'.

* Included Examples

** simple-hello.scm

  The simplest "Hello World!" program for Guile. Run it like this:

  $ guile -s simple-hello.scm

** hello

  An advanced version of the script above, with command line handling
  for the important options --help and --version.  Run it like this:

  ./hello

  or

  guile -s hello

** fact

  Command-line factorial calculator.  Run it like this:

  ./fact 5

  to calculate the factorial of 5.

path: examples/scripts/README


code:
#! /usr/local/bin/guile -s
!#
;;; Commentary:

;;; This is a command-line factorial calculator.  Run like this:
;;;
;;; ./fact 5
;;;
;;; to calculate the factorial of 5

;;; Author: Martin Grabmueller
;;; Date: 2001-05-29

;;; Code:

(use-modules (ice-9 getopt-long))

;; This is the grammar for the command line synopsis we expect.
;;
(define command-synopsis
  '((version (single-char #\v) (value #f))
    (help    (single-char #\h) (value #f))))

;; Display version information and exit.
;;
(define (display-version)
  (display "fact 0.0.1\n"))

;; Display the usage help message and exit.
;;
(define (display-help)
  (display "Usage: fact [options...] number\n")
  (display "  --help, -h           Show this usage information\n")
  (display "  --version, -v        Show version information\n"))

;; Interpret options, if --help or --version was given, print out the
;; requested information and exit.  Otherwise, calculate the factorial
;; of the argument.
;;
(define (main options)
  (let ((help-wanted (option-ref options 'help #f))
	(version-wanted (option-ref options 'version #f))
	(args (option-ref options '() '())))
    (cond
      ((or version-wanted help-wanted)
       (if version-wanted
	 (display-version))
       (if help-wanted
	 (display-help)))
      ((not (= (length args) 1))
       (display-help))
      (else
       (display (fact (string->number (car args))))
       (newline)))))

;; Calculate the factorial of n.
;;
(define (fact n)
  (if (< n 2)
    1
    (* n (fact (- n 1)))))

;; Call the main program with parsed command line options.
;;
(main (getopt-long (command-line) command-synopsis))

;; Local variables:
;; mode: scheme
;; End:

path: examples/scripts/fact


code:
#! /usr/local/bin/guile -s
!#
;;; Commentary:

;;; This is the famous Hello-World-program, written for Guile.  It is a
;;; little bit enhanced in that it understands the command line options
;;; `--help' (-h) and `--version' (-v), which print a short usage
;;; decription or version information, respectively.

;;; Author: Martin Grabmueller
;;; Date: 2001-05-29

;;; Code:

(use-modules (ice-9 getopt-long))

;; This is the grammar for the command line synopsis we expect.
;;
(define command-synopsis
  '((version (single-char #\v) (value #f))
    (help    (single-char #\h) (value #f))))

;; Display version information.
;;
(define (display-version)
  (display "hello 0.0.1\n"))

;; Display the usage help message.
;;
(define (display-help)
  (display "Usage: hello [options...]\n")
  (display "  --help, -h           Show this usage information\n")
  (display "  --version, -v        Show version information\n"))

;; Interpret options, if --help or --version was given, print out the
;; requested information and exit.  Otherwise, print the famous
;; message.
;;
(define (main options)
  (let ((help-wanted (option-ref options 'help #f))
	(version-wanted (option-ref options 'version #f)))
    (if (or version-wanted help-wanted)
	(begin
	  (if version-wanted
	      (display-version))
	  (if help-wanted
	      (display-help)))
	(begin
	  (display "Hello, World!") (newline)))))

;; Call the main program with parsed command line options.
;;
(main (getopt-long (command-line) command-synopsis))

;; Local variables:
;; mode: scheme
;; End:

path: examples/scripts/hello


code:
;;; Commentary:

;;; This is the famous Hello-World-program, written for Guile.
;;;
;;; For an advanced version, see the script `hello' in the same
;;; directory.

;;; Author: Martin Grabmueller
;;; Date: 2001-05-29

;;; Code:

(display "Hello, World!")
(newline)

;;; End of file.