code:
;;;; buffered-input.scm --- construct a port from a buffered input reader
;;;;
;;;; 	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 2.1 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

(define-module (ice-9 buffered-input)
  #:export (make-buffered-input-port
            make-line-buffered-input-port
            set-buffered-input-continuation?!))

;; @code{buffered-input-continuation?} is a property of the ports
;; created by @code{make-line-buffered-input-port} that stores the
;; read continuation flag for each such port.
(define buffered-input-continuation? (make-object-property))

(define (set-buffered-input-continuation?! port val)
  "Set the read continuation flag for @var{port} to @var{val}.

See @code{make-buffered-input-port} for the meaning and use of this
flag."
  (set! (buffered-input-continuation? port) val))

(define (make-buffered-input-port reader)
  "Construct a line-buffered input port from the specified @var{reader}.
@var{reader} should be a procedure of one argument that somehow reads
a chunk of input and returns it as a string.

The port created by @code{make-buffered-input-port} does @emph{not}
interpolate any additional characters between the strings returned by
@var{reader}.

@var{reader} should take a boolean @var{continuation?} argument.
@var{continuation?} indicates whether @var{reader} is being called to
start a logically new read operation (in which case
@var{continuation?} is @code{#f}) or to continue a read operation for
which some input has already been read (in which case
@var{continuation?} is @code{#t}).  Some @var{reader} implementations
use the @var{continuation?} argument to determine what prompt to
display to the user.

The new/continuation distinction is largely an application-level
concept: @code{set-buffered-input-continuation?!} allows an
application to specify when a read operation is considered to be new.
But note that if there is non-whitespace data already buffered in the
port when a new read operation starts, this data will be read before
the first call to @var{reader}, and so @var{reader} will be called
with @var{continuation?} set to @code{#t}."
  (let ((read-string "")
	(string-index -1))
    (letrec ((get-character
	      (lambda ()
		(cond
		 ((eof-object? read-string)
		  read-string)
		 ((>= string-index (string-length read-string))
		  (set! string-index -1)
                  (get-character))
		 ((= string-index -1)
		  (set! read-string (reader (buffered-input-continuation? port)))
                  (set! string-index 0)
                  (if (not (eof-object? read-string))
                      (get-character)
                      read-string))
		 (else
		  (let ((res (string-ref read-string string-index)))
		    (set! string-index (+ 1 string-index))
                    (if (not (char-whitespace? res))
                        (set! (buffered-input-continuation? port) #t))
		    res)))))
	     (input-waiting
	      (lambda ()
		(if (eof-object? read-string)
		    1
		    (- (string-length read-string) string-index))))
             (port #f))
      (set! port (make-soft-port (vector #f #f #f get-character #f input-waiting) "r"))
      (set! (buffered-input-continuation? port) #f)
      port)))

(define (make-line-buffered-input-port reader)
  "Construct a line-buffered input port from the specified @var{reader}.
@var{reader} should be a procedure of one argument that somehow reads
a line of input and returns it as a string @emph{without} the
terminating newline character.

The port created by @code{make-line-buffered-input-port} automatically
interpolates a newline character after each string returned by
@var{reader}.

@var{reader} should take a boolean @var{continuation?} argument.  For
the meaning and use of this argument, see
@code{make-buffered-input-port}."
  (make-buffered-input-port (lambda (continuation?)
                              (let ((str (reader continuation?)))
                                (if (eof-object? str)
                                    str
                                    (string-append str "\n"))))))

;;; buffered-input.scm ends here

license: unknown


code:
;;;; calling.scm --- Calling Conventions
;;;;
;;;; 	Copyright (C) 1995, 1996, 1997, 2000, 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 2.1 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
;;;;

(define-module (ice-9 calling)
  :export-syntax (with-excursion-function
		  with-getter-and-setter
		  with-getter
		  with-delegating-getter-and-setter
		  with-excursion-getter-and-setter
		  with-configuration-getter-and-setter
		  with-delegating-configuration-getter-and-setter
		  let-with-configuration-getter-and-setter))

;;;;
;;;
;;; This file contains a number of macros that support
;;; common calling conventions.

;;;
;;; with-excursion-function <vars> proc
;;;  <vars> is an unevaluated list of names that are bound in the caller.
;;;  proc is a procedure, called:
;;;	     (proc excursion)
;;;
;;;  excursion is a procedure isolates all changes to <vars>
;;;  in the dynamic scope of the call to proc.  In other words,
;;;  the values of <vars> are saved when proc is entered, and when
;;;  proc returns, those values are restored.   Values are also restored
;;;  entering and leaving the call to proc non-locally, such as using
;;;  call-with-current-continuation, error, or throw.
;;;
(defmacro with-excursion-function (vars proc)
  `(,proc ,(excursion-function-syntax vars)))

;;; with-getter-and-setter <vars> proc
;;;  <vars> is an unevaluated list of names that are bound in the caller.
;;;  proc is a procedure, called:
;;;	(proc getter setter)
;;;
;;;  getter and setter are procedures used to access
;;;  or modify <vars>.
;;;
;;;  setter, called with keywords arguments, modifies the named
;;;  values.   If "foo" and "bar" are among <vars>, then:
;;;
;;;	(setter :foo 1 :bar 2)
;;;	== (set! foo 1 bar 2)
;;;
;;;  getter, called with just keywords, returns
;;;  a list of the corresponding values.  For example,
;;;  if "foo" and "bar" are among the <vars>, then
;;;
;;;	(getter :foo :bar)
;;;	=> (<value-of-foo> <value-of-bar>)
;;;
;;;  getter, called with no arguments, returns a list of all accepted
;;;  keywords and the corresponding values.  If "foo" and "bar" are
;;;  the *only* <vars>, then:
;;;
;;;	(getter)
;;;	=> (:foo <value-of-bar> :bar <value-of-foo>)
;;;
;;;  The unusual calling sequence of a getter supports too handy
;;;  idioms:
;;;
;;;	(apply setter (getter))		;; save and restore
;;;
;;;	(apply-to-args (getter :foo :bar)		;; fetch and bind
;;;		    (lambda (foo bar) ....))
;;;
;;;     ;; [ "apply-to-args" is just like two-argument "apply" except that it
;;;	;;   takes its arguments in a different order.
;;;
;;;
(defmacro with-getter-and-setter (vars proc)
  `(,proc ,@ (getter-and-setter-syntax vars)))

;;; with-getter vars proc
;;;   A short-hand for a call to with-getter-and-setter.
;;;   The procedure is called:
;;;		(proc getter)
;;;
(defmacro with-getter (vars proc)
  `(,proc ,(car (getter-and-setter-syntax vars))))

;;; with-delegating-getter-and-setter <vars> get-delegate set-delegate proc
;;;   Compose getters and setters.
;;;
;;;   <vars> is an unevaluated list of names that are bound in the caller.
;;;
;;;   get-delegate is called by the new getter to extend the set of
;;;	gettable variables beyond just <vars>
;;;   set-delegate is called by the new setter to extend the set of
;;;	gettable variables beyond just <vars>
;;;
;;;   proc is a procedure that is called
;;;		(proc getter setter)
;;;
(defmacro with-delegating-getter-and-setter (vars get-delegate set-delegate proc)
  `(,proc ,@ (delegating-getter-and-setter-syntax vars get-delegate set-delegate)))

;;; with-excursion-getter-and-setter <vars> proc
;;;   <vars> is an unevaluated list of names that are bound in the caller.
;;;   proc is called:
;;;
;;;		(proc excursion getter setter)
;;;
;;;   See also:
;;;	with-getter-and-setter
;;;	with-excursion-function
;;;
(defmacro with-excursion-getter-and-setter (vars proc)
  `(,proc  ,(excursion-function-syntax vars)
	  ,@ (getter-and-setter-syntax vars)))

(define (excursion-function-syntax vars)
  (let ((saved-value-names (map gensym vars))
	(tmp-var-name (gensym "temp"))
	(swap-fn-name (gensym "swap"))
	(thunk-name (gensym "thunk")))
    `(lambda (,thunk-name)
       (letrec ((,tmp-var-name #f)
		(,swap-fn-name
		 (lambda () ,@ (map (lambda (n sn)
				      `(begin (set! ,tmp-var-name ,n)
					      (set! ,n ,sn)
					      (set! ,sn ,tmp-var-name)))
				    vars saved-value-names)))
		,@ (map (lambda (sn n) `(,sn ,n)) saved-value-names vars))
	 (dynamic-wind
	  ,swap-fn-name
	  ,thunk-name
	  ,swap-fn-name)))))

(define (getter-and-setter-syntax vars)
  (let ((args-name (gensym "args"))
	(an-arg-name (gensym "an-arg"))
	(new-val-name (gensym "new-value"))
	(loop-name (gensym "loop"))
	(kws (map symbol->keyword vars)))
    (list `(lambda ,args-name
	     (let ,loop-name ((,args-name ,args-name))
		  (if (null? ,args-name)
		      ,(if (null? kws)
			   ''()
			   `(let ((all-vals (,loop-name ',kws)))
			      (let ,loop-name ((vals all-vals)
					       (kws ',kws))
				   (if (null? vals)
				       '()
				       `(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws)))))))
		      (map (lambda (,an-arg-name)
			     (case ,an-arg-name
			       ,@ (append
				   (map (lambda (kw v) `((,kw) ,v)) kws vars)
				   `((else (throw 'bad-get-option ,an-arg-name))))))
			   ,args-name))))

	  `(lambda ,args-name
	     (let ,loop-name ((,args-name ,args-name))
		  (or (null? ,args-name)
		      (null? (cdr ,args-name))
		      (let ((,an-arg-name (car ,args-name))
			    (,new-val-name (cadr ,args-name)))
			(case ,an-arg-name
			  ,@ (append
			      (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars)
			      `((else (throw 'bad-set-option ,an-arg-name)))))
			(,loop-name (cddr ,args-name)))))))))

(define (delegating-getter-and-setter-syntax  vars get-delegate set-delegate)
  (let ((args-name (gensym "args"))
	(an-arg-name (gensym "an-arg"))
	(new-val-name (gensym "new-value"))
	(loop-name (gensym "loop"))
	(kws (map symbol->keyword vars)))
    (list `(lambda ,args-name
	     (let ,loop-name ((,args-name ,args-name))
		  (if (null? ,args-name)
		      (append!
		       ,(if (null? kws)
			    ''()
			    `(let ((all-vals (,loop-name ',kws)))
			       (let ,loop-name ((vals all-vals)
						(kws ',kws))
				    (if (null? vals)
					'()
					`(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws)))))))
		       (,get-delegate))
		      (map (lambda (,an-arg-name)
			     (case ,an-arg-name
			       ,@ (append
				   (map (lambda (kw v) `((,kw) ,v)) kws vars)
				   `((else (car (,get-delegate ,an-arg-name)))))))
			   ,args-name))))

	  `(lambda ,args-name
	     (let ,loop-name ((,args-name ,args-name))
		  (or (null? ,args-name)
		      (null? (cdr ,args-name))
		      (let ((,an-arg-name (car ,args-name))
			    (,new-val-name (cadr ,args-name)))
			(case ,an-arg-name
			  ,@ (append
			      (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars)
			      `((else  (,set-delegate ,an-arg-name ,new-val-name)))))
			(,loop-name (cddr ,args-name)))))))))

;;; with-configuration-getter-and-setter <vars-etc> proc
;;;
;;;  Create a getter and setter that can trigger arbitrary computation.
;;;
;;;  <vars-etc> is a list of variable specifiers, explained below.
;;;  proc is called:
;;;
;;;		(proc getter setter)
;;;
;;;   Each element of the <vars-etc> list is of the form:
;;;
;;;	(<var> getter-hook setter-hook)
;;;
;;;   Both hook elements are evaluated; the variable name is not.
;;;   Either hook may be #f or procedure.
;;;
;;;   A getter hook is a thunk that returns a value for the corresponding
;;;   variable.   If omitted (#f is passed), the binding of <var> is
;;;   returned.
;;;
;;;   A setter hook is a procedure of one argument that accepts a new value
;;;   for the corresponding variable.  If omitted, the binding of <var>
;;;   is simply set using set!.
;;;
(defmacro with-configuration-getter-and-setter (vars-etc proc)
  `((lambda (simpler-get simpler-set body-proc)
      (with-delegating-getter-and-setter ()
	simpler-get simpler-set body-proc))

    (lambda (kw)
      (case kw
	,@(map (lambda (v) `((,(symbol->keyword (car v)))
			     ,(cond
			       ((cadr v)	=> list)
			       (else		`(list ,(car v))))))
	       vars-etc)))

    (lambda (kw new-val)
      (case kw
	,@(map (lambda (v) `((,(symbol->keyword (car v)))
			     ,(cond
			       ((caddr v)	=> (lambda (proc) `(,proc new-val)))
			       (else		`(set! ,(car v) new-val)))))
	       vars-etc)))

       ,proc))

(defmacro with-delegating-configuration-getter-and-setter (vars-etc delegate-get delegate-set proc)
  `((lambda (simpler-get simpler-set body-proc)
      (with-delegating-getter-and-setter ()
	simpler-get simpler-set body-proc))

    (lambda (kw)
      (case kw
	,@(append! (map (lambda (v) `((,(symbol->keyword (car v)))
				      ,(cond
					((cadr v)	=> list)
					(else		`(list ,(car v))))))
			vars-etc)
		   `((else (,delegate-get kw))))))

    (lambda (kw new-val)
      (case kw
	,@(append! (map (lambda (v) `((,(symbol->keyword (car v)))
				      ,(cond
					((caddr v)	=> (lambda (proc) `(,proc new-val)))
					(else		`(set! ,(car v) new-val)))))
			vars-etc)
		   `((else (,delegate-set kw new-val))))))

    ,proc))

;;; let-configuration-getter-and-setter <vars-etc> proc
;;;
;;;   This procedure is like with-configuration-getter-and-setter (q.v.)
;;;   except that each element of <vars-etc> is:
;;;
;;;		(<var> initial-value getter-hook setter-hook)
;;;
;;;   Unlike with-configuration-getter-and-setter, let-configuration-getter-and-setter
;;;   introduces bindings for the variables named in <vars-etc>.
;;;   It is short-hand for:
;;;
;;;		(let ((<var1> initial-value-1)
;;;		      (<var2> initial-value-2)
;;;			...)
;;;		  (with-configuration-getter-and-setter ((<var1> v1-get v1-set) ...) proc))
;;;
(defmacro let-with-configuration-getter-and-setter (vars-etc proc)
  `(let ,(map (lambda (v) `(,(car v) ,(cadr v))) vars-etc)
     (with-configuration-getter-and-setter ,(map (lambda (v) `(,(car v) ,(caddr v) ,(cadddr v))) vars-etc)
					   ,proc)))


code:
;;; Guile object channel

;; 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 2.1 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

;;; Commentary:

;; Now you can use Guile's modules in Emacs Lisp like this:
;;
;;   (guile-import current-module)
;;   (guile-import module-ref)
;;
;;   (setq assq (module-ref (current-module) 'assq))
;;     => ("<guile>" %%1%% . "#<primitive-procedure assq>")
;;
;;   (guile-use-modules (ice-9 documentation))
;;
;;   (object-documentation assq)
;;     =>
;;  " - primitive: assq key alist
;;    - primitive: assv key alist
;;    - primitive: assoc key alist
;;        Fetches the entry in ALIST that is associated with KEY.  To decide
;;        whether the argument KEY matches a particular entry in ALIST,
;;        `assq' compares keys with `eq?', `assv' uses `eqv?' and `assoc'
;;        uses `equal?'.  If KEY cannot be found in ALIST (according to
;;        whichever equality predicate is in use), then `#f' is returned.
;;        These functions return the entire alist entry found (i.e. both the
;;        key and the value)."
;;
;; Probably we can use GTK in Emacs Lisp.  Can anybody try it?
;;
;; I have also implemented Guile Scheme mode and Scheme Interaction mode.
;; Just put the following lines in your ~/.emacs:
;;
;;   (require 'guile-scheme)
;;   (setq initial-major-mode 'scheme-interaction-mode)
;;
;; Currently, the following commands are available:
;;
;;   M-TAB    guile-scheme-complete-symbol
;;   M-C-x    guile-scheme-eval-define
;;   C-x C-e  guile-scheme-eval-last-sexp
;;   C-c C-b  guile-scheme-eval-buffer
;;   C-c C-r  guile-scheme-eval-region
;;   C-c :    guile-scheme-eval-expression
;;
;; I'll write more commands soon, or if you want to hack, please take
;; a look at the following files:
;;
;;   guile-core/ice-9/channel.scm       ;; object channel
;;   guile-core/emacs/guile.el          ;; object adapter
;;   guile-core/emacs/guile-emacs.scm   ;; Guile <-> Emacs channels
;;   guile-core/emacs/guile-scheme.el   ;; Guile Scheme mode
;;
;; As always, there are more than one bugs ;)

;;; Code:

(define-module (ice-9 channel)
  :export (make-object-channel
	   channel-open
	   channel-print-value
	   channel-print-token))

;;;
;;; Channel type
;;;

(define channel-type
  (make-record-type 'channel '(stdin stdout printer token-module)))

(define make-channel (record-constructor channel-type))

(define (make-object-channel printer)
  (make-channel (current-input-port)
		(current-output-port)
		printer
		(make-module)))

(define channel-stdin (record-accessor channel-type 'stdin))
(define channel-stdout (record-accessor channel-type 'stdout))
(define channel-printer (record-accessor channel-type 'printer))
(define channel-token-module (record-accessor channel-type 'token-module))

;;;
;;; Channel
;;;

(define (channel-open ch)
  (let ((stdin (channel-stdin ch))
	(stdout (channel-stdout ch))
	(printer (channel-printer ch))
	(token-module (channel-token-module ch)))
    (let loop ()
      (catch #t
	(lambda ()
	  (channel:prompt stdout)
	  (let ((cmd (read stdin)))
	    (if (eof-object? cmd)
	      (throw 'quit)
	      (case cmd
		((eval)
		 (module-use! (current-module) token-module)
		 (printer ch (eval (read stdin) (current-module))))
		((destroy)
		 (let ((token (read stdin)))
		   (if (module-defined? token-module token)
		     (module-remove! token-module token)
		     (channel:error stdout "Invalid token: ~S" token))))
		((quit)
		 (throw 'quit))
		(else
		 (channel:error stdout "Unknown command: ~S" cmd)))))
	  (loop))
	(lambda (key . args)
	  (case key
	    ((quit) (throw 'quit))
	    (else
	     (format stdout "exception = ~S\n"
		     (list key (apply format #f (cadr args) (caddr args))))
	     (loop))))))))

(define (channel-print-value ch val)
  (format (channel-stdout ch) "value = ~S\n" val))

(define (channel-print-token ch val)
  (let* ((token (symbol-append (gensym "%%") '%%))
	 (pair (cons token (object->string val))))
    (format (channel-stdout ch) "token = ~S\n" pair)
    (module-define! (channel-token-module ch) token val)))

(define (channel:prompt port)
  (display "channel> " port)
  (force-output port))

(define (channel:error port msg . args)
  (display "ERROR: " port)
  (apply format port msg args)
  (newline port))

;;;
;;; Guile 1.4 compatibility
;;;

(define guile:eval eval)
(define eval
  (if (= (car (procedure-property guile:eval 'arity)) 1)
    (lambda (x e) (guile:eval x))
    guile:eval))

(define object->string
  (if (defined? 'object->string)
    object->string
    (lambda (x) (format #f "~S" x))))

;;; channel.scm ends here


code:
;;;; common-list.scm --- COMMON LISP list functions for Scheme
;;;;
;;;; 	Copyright (C) 1995, 1996, 1997, 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 2.1 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
;;;;

;;; Commentary:

;; These procedures are exported:
;;  (adjoin e l)
;;  (union l1 l2)
;;  (intersection l1 l2)
;;  (set-difference l1 l2)
;;  (reduce-init p init l)
;;  (reduce p l)
;;  (some pred l . rest)
;;  (every pred l . rest)
;;  (notany pred . ls)
;;  (notevery pred . ls)
;;  (count-if pred l)
;;  (find-if pred l)
;;  (member-if pred l)
;;  (remove-if pred l)
;;  (remove-if-not pred l)
;;  (delete-if! pred l)
;;  (delete-if-not! pred l)
;;  (butlast lst n)
;;  (and? . args)
;;  (or? . args)
;;  (has-duplicates? lst)
;;  (pick p l)
;;  (pick-mappings p l)
;;  (uniq l)
;;
;; See docstrings for each procedure for more info.  See also module
;; `(srfi srfi-1)' for a complete list handling library.

;;; Code:

(define-module (ice-9 common-list)
  :export (adjoin union intersection set-difference reduce-init reduce
	   some every notany notevery count-if find-if member-if remove-if
	   remove-if-not delete-if! delete-if-not! butlast and? or?
	   has-duplicates? pick pick-mappings uniq))

;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme
; Copyright (C) 1991, 1993, 1995 Aubrey Jaffer.
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1.  Any copy made of this software must include this copyright notice
;in full.
;
;2.  I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3.  In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.

(define (adjoin e l)
  "Return list L, possibly with element E added if it is not already in L."
  (if (memq e l) l (cons e l)))

(define (union l1 l2)
  "Return a new list that is the union of L1 and L2.
Elements that occur in both lists occur only once in
the result list."
  (cond ((null? l1) l2)
	((null? l2) l1)
	(else (union (cdr l1) (adjoin (car l1) l2)))))

(define (intersection l1 l2)
  "Return a new list that is the intersection of L1 and L2.
Only elements that occur in both lists occur in the result list."
  (if (null? l2) l2
      (let loop ((l1 l1) (result '()))
	(cond ((null? l1) (reverse! result))
	      ((memv (car l1) l2) (loop (cdr l1) (cons (car l1) result)))
	      (else (loop (cdr l1) result))))))

(define (set-difference l1 l2)
  "Return elements from list L1 that are not in list L2."
  (let loop ((l1 l1) (result '()))
    (cond ((null? l1) (reverse! result))
	  ((memv (car l1) l2) (loop (cdr l1) result))
	  (else (loop (cdr l1) (cons (car l1) result))))))

(define (reduce-init p init l)
  "Same as `reduce' except it implicitly inserts INIT at the start of L."
  (if (null? l)
      init
      (reduce-init p (p init (car l)) (cdr l))))

(define (reduce p l)
  "Combine all the elements of sequence L using a binary operation P.
The combination is left-associative.  For example, using +, one can
add up all the elements.  `reduce' allows you to apply a function which
accepts only two arguments to more than 2 objects.  Functional
programmers usually refer to this as foldl."
  (cond ((null? l) l)
	((null? (cdr l)) (car l))
	(else (reduce-init p (car l) (cdr l)))))

(define (some pred l . rest)
  "PRED is a boolean function of as many arguments as there are list
arguments to `some', i.e., L plus any optional arguments.  PRED is
applied to successive elements of the list arguments in order.  As soon
as one of these applications returns a true value, return that value.
If no application returns a true value, return #f.
All the lists should have the same length."
  (cond ((null? rest)
	 (let mapf ((l l))
	   (and (not (null? l))
		(or (pred (car l)) (mapf (cdr l))))))
	(else (let mapf ((l l) (rest rest))
		(and (not (null? l))
		     (or (apply pred (car l) (map car rest))
			 (mapf (cdr l) (map cdr rest))))))))

(define (every pred l . rest)
  "Return #t iff every application of PRED to L, etc., returns #t.
Analogous to `some' except it returns #t if every application of
PRED is #t and #f otherwise."
  (cond ((null? rest)
	 (let mapf ((l l))
	   (or (null? l)
	       (and (pred (car l)) (mapf (cdr l))))))
	(else (let mapf ((l l) (rest rest))
		(or (null? l)
		    (and (apply pred (car l) (map car rest))
			 (mapf (cdr l) (map cdr rest))))))))

(define (notany pred . ls)
  "Return #t iff every application of PRED to L, etc., returns #f.
Analogous to some but returns #t if no application of PRED returns a
true value or #f as soon as any one does."
  (not (apply some pred ls)))

(define (notevery pred . ls)
  "Return #t iff there is an application of PRED to L, etc., that returns #f.
Analogous to some but returns #t as soon as an application of PRED returns #f,
or #f otherwise."
  (not (apply every pred ls)))

(define (count-if pred l)
  "Return the number of elements in L for which (PRED element) returns true."
  (let loop ((n 0) (l l))
    (cond ((null? l) n)
	  ((pred (car l)) (loop (+ n 1) (cdr l)))
	  (else (loop n (cdr l))))))

(define (find-if pred l)
  "Search for the first element in L for which (PRED element) returns true.
If found, return that element, otherwise return #f."
  (cond ((null? l) #f)
	((pred (car l)) (car l))
	(else (find-if pred (cdr l)))))

(define (member-if pred l)
  "Return the first sublist of L for whose car PRED is true."
  (cond ((null? l) #f)
	((pred (car l)) l)
	(else (member-if pred (cdr l)))))

(define (remove-if pred l)
  "Remove all elements from L where (PRED element) is true.
Return everything that's left."
  (let loop ((l l) (result '()))
    (cond ((null? l) (reverse! result))
	  ((pred (car l)) (loop (cdr l) result))
	  (else (loop (cdr l) (cons (car l) result))))))

(define (remove-if-not pred l)
  "Remove all elements from L where (PRED element) is #f.
Return everything that's left."
  (let loop ((l l) (result '()))
    (cond ((null? l) (reverse! result))
	  ((not (pred (car l))) (loop (cdr l) result))
	  (else (loop (cdr l) (cons (car l) result))))))

(define (delete-if! pred l)
  "Destructive version of `remove-if'."
  (let delete-if ((l l))
    (cond ((null? l) '())
	  ((pred (car l)) (delete-if (cdr l)))
	  (else
	   (set-cdr! l (delete-if (cdr l)))
	   l))))

(define (delete-if-not! pred l)
  "Destructive version of `remove-if-not'."
  (let delete-if-not ((l l))
    (cond ((null? l) '())
	  ((not (pred (car l))) (delete-if-not (cdr l)))
	  (else
	   (set-cdr! l (delete-if-not (cdr l)))
	   l))))

(define (butlast lst n)
  "Return all but the last N elements of LST."
  (letrec ((l (- (length lst) n))
	   (bl (lambda (lst n)
		 (cond ((null? lst) lst)
		       ((positive? n)
			(cons (car lst) (bl (cdr lst) (+ -1 n))))
		       (else '())))))
    (bl lst (if (negative? n)
		(error "negative argument to butlast" n)
		l))))

(define (and? . args)
  "Return #t iff all of ARGS are true."
  (cond ((null? args) #t)
	((car args) (apply and? (cdr args)))
	(else #f)))

(define (or? . args)
  "Return #t iff any of ARGS is true."
  (cond ((null? args) #f)
	((car args) #t)
	(else (apply or? (cdr args)))))

(define (has-duplicates? lst)
  "Return #t iff 2 members of LST are equal?, else #f."
  (cond ((null? lst) #f)
	((member (car lst) (cdr lst)) #t)
	(else (has-duplicates? (cdr lst)))))

(define (pick p l)
  "Apply P to each element of L, returning a list of elts
for which P returns a non-#f value."
  (let loop ((s '())
	     (l l))
    (cond
     ((null? l) 	s)
     ((p (car l))	(loop (cons (car l) s) (cdr l)))
     (else		(loop s (cdr l))))))

(define (pick-mappings p l)
  "Apply P to each element of L, returning a list of the
non-#f return values of P."
  (let loop ((s '())
	     (l l))
    (cond
     ((null? l) 	s)
     ((p (car l)) =>	(lambda (mapping) (loop (cons mapping s) (cdr l))))
     (else		(loop s (cdr l))))))

(define (uniq l)
  "Return a list containing elements of L, with duplicates removed."
  (let loop ((acc '())
	     (l l))
    (if (null? l)
	(reverse! acc)
	(loop (if (memq (car l) acc)
		  acc
		  (cons (car l) acc))
	      (cdr l)))))

;;; common-list.scm ends here


code:
;;;;    Copyright (C) 1997, 2000, 2001, 2002, 2003, 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 2.1 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
;;;;

(use-modules (ice-9 pretty-print))

(define expansion-eval-closure (make-fluid))

(define (env->eval-closure env)
  (or (and env
           (car (last-pair env)))
      (module-eval-closure the-root-module)))

(define sc-macro
  (procedure->memoizing-macro
   (lambda (exp env)
     (with-fluids ((expansion-eval-closure (env->eval-closure env)))
       (sc-expand exp)))))

(define sc-expand #f)
(define sc-expand3 #f)
(define sc-chi #f)
(define install-global-transformer #f)
(define syntax-dispatch #f)
(define syntax-error #f)

(define bound-identifier=? #f)
(define datum->syntax-object #f)
(define free-identifier=? #f)
(define generate-temporaries #f)
(define identifier? #f)
(define syntax-object->datum #f)

(define primitive-syntax '(quote lambda letrec if set! begin define or
                                 and let let* cond do quasiquote unquote
                                 unquote-splicing case))

(for-each (lambda (symbol)
            (set-symbol-property! symbol 'primitive-syntax #t))
          primitive-syntax)

(define (void) *unspecified*)

(define andmap
  (lambda (f first . rest)
    (or (null? first)
        (if (null? rest)
            (let andmap ((first first))
              (let ((x (car first)) (first (cdr first)))
                (if (null? first)
                    (f x)
                    (and (f x) (andmap first)))))
            (let andmap ((first first) (rest rest))
              (let ((x (car first))
                    (xr (map car rest))
                    (first (cdr first))
                    (rest (map cdr rest)))
                (if (null? first)
                    (apply f (cons x xr))
                    (and (apply f (cons x xr)) (andmap first rest)))))))))

(define (error who format-string why what)
  (start-stack 'syncase-stack
               (scm-error 'misc-error
                          who
                          "~A ~S"
                          (list why what)
                          '())))

(define the-syncase-module (current-module))
(define the-syncase-eval-closure (module-eval-closure the-syncase-module))

(fluid-set! expansion-eval-closure the-syncase-eval-closure)

(define (putprop symbol key binding)
  (let* ((eval-closure (fluid-ref expansion-eval-closure))
         ;; Why not simply do (eval-closure symbol #t)?
         ;; Answer: That would overwrite imported bindings
         (v (or (eval-closure symbol #f) ;lookup
                (eval-closure symbol #t) ;create it locally
                )))
    ;; Don't destroy Guile macros corresponding to
    ;; primitive syntax when syncase boots.
    (if (not (and (symbol-property symbol 'primitive-syntax)
                  (eq? eval-closure the-syncase-eval-closure)))
        (variable-set! v sc-macro))
    ;; Properties are tied to variable objects
    (set-object-property! v key binding)))

(define (getprop symbol key)
  (let* ((v ((fluid-ref expansion-eval-closure) symbol #f)))
    (and v
         (or (object-property v key)
             (and (variable-bound? v)
                  (macro? (variable-ref v))
                  (macro-transformer (variable-ref v)) ;non-primitive
                  guile-macro)))))

(define guile-macro
  (cons 'external-macro
        (lambda (e r w s)
          (let ((e (syntax-object->datum e)))
            (if (symbol? e)
                ;; pass the expression through
                e
                (let* ((eval-closure (fluid-ref expansion-eval-closure))
                       (m (variable-ref (eval-closure (car e) #f))))
                  (if (eq? (macro-type m) 'syntax)
                      ;; pass the expression through
                      e
                      ;; perform Guile macro transform
                      (let ((e ((macro-transformer m)
                                e
                                (append r (list eval-closure)))))
                        (if (variable? e)
                            e
                            (if (null? r)
                                (sc-expand e)
                                (sc-chi e r w)))))))))))

(define gensym
  (let ((counter 0))
    (define next-id
      (lambda ()
        (let ((result counter))
          (set! counter (+ counter 1))
          result)))

    ;; actual gensym body code.
    (lambda (. rest)
      (let* ((next-val (next-id))
             (valstr (number->string next-val)))
        (cond
         ((null? rest)
          (string->symbol (string-append "syntmp-" valstr)))
         ((null? (cdr rest))
          (string->symbol (string-append "syntmp-" (car rest) "-" valstr)))
         (else
          (error
           (string-append
            "syncase's gensym expected 0 or 1 arguments, got "
            (length rest)))))))))

(load-from-path "ice-9/psyntax.ss")

(define internal-eval (nested-ref the-scm-module '(%app modules guile eval)))

(define (eval x environment)
  (internal-eval (if (and (pair? x)
                          (equal? (car x) "noexpand"))
                     (cadr x)
                     (sc-expand x))
                 environment))

(define (syncase exp)
  (with-fluids ((expansion-eval-closure
                 (module-eval-closure (current-module))))
    (sc-expand exp)))

(set-module-transformer! the-syncase-module syncase)

(fluid-set! expansion-eval-closure (env->eval-closure #f))

(let* ((top_srcdir (assoc-ref %guile-build-info 'top_srcdir))
       (source (string-append top_srcdir "/ice-9/psyntax.ss"))
       (target (string-append top_srcdir "/ice-9/psyntax.pp"))
       (temp (string-append target ".tmp")))
  (call-with-input-file source
    (lambda (in)
      (call-with-output-file temp
        (lambda (out)
          (display ";;; -*- mode: scheme; geiser-scheme-implementation: guile -*-" out)
          (newline out)
          (let loop ((x (read in)))
            (if (eof-object? x)
                (begin
                  (close-port out)
                  (close-port in))
                (begin
                  (pretty-print (sc-expand3 x 'c '(compile load eval)) out)
                  (newline out)
                  (loop (read in)))))))))
  (system* "mv" "-f" temp target))


code:
;;;; 	Copyright (C) 1996, 1997, 1998, 1999, 2001, 2006 Free Software Foundation
;;;;
;;;; 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 2.1 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
;;;;
;;;; The author can be reached at djurfeldt@nada.kth.se
;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
;;;;

(define-module (ice-9 debug)
  :export (frame-number->index trace untrace trace-stack untrace-stack))

;;; {Misc}
;;;
(define (frame-number->index n . stack)
  (let ((stack (if (null? stack)
		   (fluid-ref the-last-stack)
		   (car stack))))
    (if (memq 'backwards (debug-options))
	n
	(- (stack-length stack) n 1))))

;;; {Trace}
;;;
;;; This code is just an experimental prototype (e. g., it is not
;;; thread safe), but since it's at the same time useful, it's
;;; included anyway.
;;;
(define traced-procedures '())

(define (trace . args)
  (if (null? args)
      (nameify traced-procedures)
      (begin
	(for-each (lambda (proc)
		    (if (not (procedure? proc))
			(error "trace: Wrong type argument:" proc))
		    (set-procedure-property! proc 'trace #t)
		    (if (not (memq proc traced-procedures))
			(set! traced-procedures
			      (cons proc traced-procedures))))
		  args)
	(trap-set! apply-frame-handler trace-entry)
	(trap-set! exit-frame-handler trace-exit)
	;; We used to reset `trace-level' here to 0, but this is wrong
	;; if `trace' itself is being traced, since `trace-exit' will
	;; then decrement `trace-level' to -1!  It shouldn't actually
	;; be necessary to set `trace-level' here at all.
	(debug-enable 'trace)
	(nameify args))))

(define (untrace . args)
  (if (and (null? args)
	   (not (null? traced-procedures)))
      (apply untrace traced-procedures)
      (begin
	(for-each (lambda (proc)
		    (set-procedure-property! proc 'trace #f)
		    (set! traced-procedures (delq! proc traced-procedures)))
		  args)
	(if (null? traced-procedures)
	    (debug-disable 'trace))
	(nameify args))))

(define (nameify ls)
  (map (lambda (proc)
	 (let ((name (procedure-name proc)))
	   (or name proc)))
       ls))

(define trace-level 0)
(add-hook! abort-hook (lambda () (set! trace-level 0)))

(define traced-stack-ids (list 'repl-stack))
(define trace-all-stacks? #f)

(define (trace-stack id)
  "Add ID to the set of stack ids for which tracing is active.
If `#t' is in this set, tracing is active regardless of stack context.
To remove ID again, use `untrace-stack'.  If you add the same ID twice
using `trace-stack', you will need to remove it twice."
  (set! traced-stack-ids (cons id traced-stack-ids))
  (set! trace-all-stacks? (memq #t traced-stack-ids)))

(define (untrace-stack id)
  "Remove ID from the set of stack ids for which tracing is active."
  (set! traced-stack-ids (delq1! id traced-stack-ids))
  (set! trace-all-stacks? (memq #t traced-stack-ids)))

(define (trace-entry key cont tail)
  (if (or trace-all-stacks?
	  (memq (stack-id cont) traced-stack-ids))
      (let ((cep (current-error-port))
	    (frame (last-stack-frame cont)))
	(if (not tail)
	    (set! trace-level (+ trace-level 1)))
	(let indent ((n trace-level))
	  (cond ((> n 1) (display "|  " cep) (indent (- n 1)))))
	(display-application frame cep)
	(newline cep)))
  ;; It's not necessary to call the continuation since
  ;; execution will continue if the handler returns
  ;(cont #f)
  )

(define (trace-exit key cont retval)
  (if (or trace-all-stacks?
	  (memq (stack-id cont) traced-stack-ids))
      (let ((cep (current-error-port)))
	(set! trace-level (- trace-level 1))
	(let indent ((n trace-level))
	  (cond ((> n 0) (display "|  " cep) (indent (- n 1)))))
	(write retval cep)
	(newline cep))))

;;; A fix to get the error handling working together with the module system.
;;;
;;; XXX - Still needed?
(module-set! the-root-module 'debug-options debug-options)


code:
;;;; Guile Debugger

;;; Copyright (C) 1999, 2001, 2002, 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 2.1 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

(define-module (ice-9 debugger)
  #:use-module (ice-9 debugger command-loop)
  #:use-module (ice-9 debugger state)
  #:use-module (ice-9 debugger utils)
  #:use-module (ice-9 format)
  #:export (debug-stack
	    debug
	    debug-last-error
	    debugger-error
	    debugger-quit
	    debugger-input-port
	    debugger-output-port
	    debug-on-error)
  #:no-backtrace)

;;; The old (ice-9 debugger) has been factored into its constituent
;;; parts:
;;;
;;; (ice-9 debugger) - public interface to all of the following
;;;
;;; (... commands) - procedures implementing the guts of the commands
;;;                  provided by the interactive debugger
;;;
;;; (... command-loop) - binding these commands into the interactive
;;;                      debugger command loop
;;;
;;; (... state) - implementation of an object that tracks current
;;;               debugger state
;;;
;;; (... utils) - utilities for printing out frame and stack
;;;               information in various formats
;;;
;;; The division between (... commands) and (... command-loop) exists
;;; because I (NJ) have another generic command loop implementation
;;; under development, and I want to be able to switch easily between
;;; that and the command loop implementation here.  Thus the
;;; procedures in this file delegate to a debugger command loop
;;; implementation via the `debugger-command-loop-*' interface.  The
;;; (ice-9 debugger command-loop) implementation can be replaced by
;;; any other that implements the `debugger-command-loop-*' interface
;;; simply by changing the relevant #:use-module line above.
;;;
;;; - Neil Jerram <neil@ossau.uklinux.net> 2002-10-26, updated 2005-07-09

(define *not-yet-introduced* #t)

(define (debug-stack stack . flags)
  "Invoke the Guile debugger to explore the specified @var{stack}.

@var{flags}, if present, are keywords indicating characteristics of
the debugging session: the valid keywords are as follows.

@table @code
@item #:continuable
Indicates that the debugger is being invoked from a context (such as
an evaluator trap handler) where it is possible to return from the
debugger and continue normal code execution.  This enables the
@dfn{continuing execution} commands, for example @code{continue} and
@code{step}.

@item #:with-introduction
Indicates that the debugger should display an introductory message.
@end table"
  (start-stack 'debugger
    (let ((state (apply make-state stack 0 flags)))
      (with-input-from-port (debugger-input-port)
	(lambda ()
	  (with-output-to-port (debugger-output-port)
	    (lambda ()
	      (if (or *not-yet-introduced*
		      (memq #:with-introduction flags))
		  (let ((ssize (stack-length stack)))
		    (display "This is the Guile debugger -- for help, type `help'.\n")
		    (set! *not-yet-introduced* #f)
		    (if (= ssize 1)
			(display "There is 1 frame on the stack.\n\n")
			(format #t "There are ~A frames on the stack.\n\n" ssize))))
	      (write-state-short state)
	      (debugger-command-loop state))))))))

(define (debug)
  "Invoke the Guile debugger to explore the context of the last error."
  (let ((stack (fluid-ref the-last-stack)))
    (if stack
	(debug-stack stack)
	(display "Nothing to debug.\n"))))

(define debug-last-error debug)

(define (debugger-error message)
  "Signal a debugger usage error with message @var{message}."
  (debugger-command-loop-error message))

(define (debugger-quit)
  "Exit the debugger."
  (debugger-command-loop-quit))

;;; {Debugger Input and Output Ports}

(define debugger-input-port
  (let ((input-port (current-input-port)))
    (make-procedure-with-setter
     (lambda () input-port)
     (lambda (port) (set! input-port port)))))

(define debugger-output-port
  (let ((output-port (current-output-port)))
    (make-procedure-with-setter
     (lambda () output-port)
     (lambda (port) (set! output-port port)))))

;;; {Debug on Error}

(define (debug-on-error syms)
  "Enable or disable debug on error."
  (set! lazy-handler-dispatch
	(if syms
	    (lambda (key . args)
	      (if (memq key syms)
		  (begin
		    (debug-stack (make-stack #t lazy-handler-dispatch)
				 #:with-introduction
				 #:continuable)
		    (throw 'abort key)))
	      (apply default-lazy-handler key args))
	    default-lazy-handler)))

;;; (ice-9 debugger) ends here.


code:
;;;; Guile Debugger command loop

;;; Copyright (C) 1999, 2001, 2002, 2003, 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 2.1 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

(define-module (ice-9 debugger command-loop)
  #:use-module ((ice-9 debugger commands) :prefix debugger:)
  #:export (debugger-command-loop
	    debugger-command-loop-error
	    debugger-command-loop-quit)
  #:no-backtrace)

;;; {Interface used by (ice-9 debugger).}

(define (debugger-command-loop state)
  (read-and-dispatch-commands state (current-input-port)))

(define (debugger-command-loop-error message)
  (user-error message))

(define (debugger-command-loop-quit)
  (throw 'exit-debugger))

;;; {Implementation.}

(define debugger-prompt "debug> ")

(define (debugger-handler key . args)
  (case key
    ((exit-debugger) #f)
    ((signal)
     ;; Restore stack
     (fluid-set! the-last-stack (fluid-ref before-signal-stack))
     (apply display-error #f (current-error-port) args))
    (else
     (display "Internal debugger error:\n")
     (save-stack debugger-handler)
     (apply throw key args)))
  (throw 'exit-debugger))		;Pop the stack

(define (read-and-dispatch-commands state port)
  (catch 'exit-debugger
    (lambda ()
      (lazy-catch #t
        (lambda ()
	  (with-fluids ((last-command #f))
	    (let loop ()
	      (read-and-dispatch-command state port)
	      (loop))))
	debugger-handler))
    (lambda args
      *unspecified*)))

(define set-readline-prompt! #f)

(define (read-and-dispatch-command state port)
  (if (using-readline?)
      (begin
	;; Import set-readline-prompt! if we haven't already.
	(or set-readline-prompt!
	    (set! set-readline-prompt!
		  (module-ref (resolve-module '(ice-9 readline))
			      'set-readline-prompt!)))
	(set-readline-prompt! debugger-prompt debugger-prompt))
      (display debugger-prompt))
  (force-output)			;This should not be necessary...
  (let ((token (read-token port)))
    (cond ((eof-object? token)
	   (throw 'exit-debugger))
	  ((not token)
	   (discard-rest-of-line port)
	   (catch-user-errors port (lambda () (run-last-command state))))
	  (else
	   (catch-user-errors port
	     (lambda ()
	       (dispatch-command token command-table state port)))))))

(define (run-last-command state)
  (let ((procedure (fluid-ref last-command)))
    (if procedure
	(procedure state))))

(define (catch-user-errors port thunk)
  (catch 'debugger-user-error
	 thunk
	 (lambda (key . objects)
	   (apply user-warning objects)
	   (discard-rest-of-line port))))

(define last-command (make-fluid))

(define (user-warning . objects)
  (for-each (lambda (object)
	      (display object))
	    objects)
  (newline))

(define (user-error . objects)
  (apply throw 'debugger-user-error objects))

;;;; Command dispatch

(define (dispatch-command string table state port)
  (let ((value (command-table-value table string)))
    (if value
	(dispatch-command/value value state port)
	(user-error "Unknown command: " string))))

(define (dispatch-command/value value state port)
  (cond ((command? value)
	 (dispatch-command/command value state port))
	((command-table? value)
	 (dispatch-command/table value state port))
	((list? value)
	 (dispatch-command/name value state port))
	(else
	 (error "Unrecognized command-table value: " value))))

(define (dispatch-command/command command state port)
  (let ((procedure (command-procedure command))
	(arguments ((command-parser command) port)))
    (let ((procedure (lambda (state) (apply procedure state arguments))))
      (warn-about-extra-args port)
      (fluid-set! last-command procedure)
      (procedure state))))

(define (warn-about-extra-args port)
  ;; **** modify this to show the arguments.
  (let ((char (skip-whitespace port)))
    (cond ((eof-object? char) #f)
	  ((char=? #\newline char) (read-char port))
	  (else
	   (user-warning "Extra arguments at end of line: "
			 (read-rest-of-line port))))))

(define (dispatch-command/table table state port)
  (let ((token (read-token port)))
    (if (or (eof-object? token)
	    (not token))
	(user-error "Command name too short.")
	(dispatch-command token table state port))))

(define (dispatch-command/name name state port)
  (let ((value (lookup-command name)))
    (cond ((not value)
	   (apply user-error "Unknown command name: " name))
	  ((command-table? value)
	   (apply user-error "Partial command name: " name))
	  (else
	   (dispatch-command/value value state port)))))

;;;; Command definition

(define (define-command name argument-template procedure)
  (let ((name (canonicalize-command-name name)))
    (add-command name
		 (make-command name
			       (argument-template->parser argument-template)
			       (procedure-documentation procedure)
			       procedure)
		 command-table)
    name))

(define (define-command-alias name1 name2)
  (let ((name1 (canonicalize-command-name name1)))
    (add-command name1 (canonicalize-command-name name2) command-table)
    name1))

(define (argument-template->parser template)
  ;; Deliberately handles only cases that occur in "commands.scm".
  (cond ((eq? 'tokens template)
	 (lambda (port)
	   (let loop ((tokens '()))
	     (let ((token (read-token port)))
	       (if (or (eof-object? token)
		       (not token))
		   (list (reverse! tokens))
		   (loop (cons token tokens)))))))
	((null? template)
	 (lambda (port)
	   '()))
	((and (pair? template)
	      (null? (cdr template))
	      (eq? 'object (car template)))
	 (lambda (port)
	   (list (read port))))
	((and (pair? template)
	      (equal? ''optional (car template))
	      (pair? (cdr template))
	      (null? (cddr template)))
	 (case (cadr template)
	   ((token)
	    (lambda (port)
	      (let ((token (read-token port)))
		(if (or (eof-object? token)
			(not token))
		    (list #f)
		    (list token)))))
	   ((exact-integer)
	    (lambda (port)
	      (list (parse-optional-exact-integer port))))
	   ((exact-nonnegative-integer)
	    (lambda (port)
	      (list (parse-optional-exact-nonnegative-integer port))))
	   ((object)
	    (lambda (port)
	      (list (parse-optional-object port))))
	   (else
	    (error "Malformed argument template: " template))))
	(else
	 (error "Malformed argument template: " template))))

(define (parse-optional-exact-integer port)
  (let ((object (parse-optional-object port)))
    (if (or (not object)
	    (and (integer? object)
		 (exact? object)))
	object
	(user-error "Argument not an exact integer: " object))))

(define (parse-optional-exact-nonnegative-integer port)
  (let ((object (parse-optional-object port)))
    (if (or (not object)
	    (and (integer? object)
		 (exact? object)
		 (not (negative? object))))
	object
	(user-error "Argument not an exact non-negative integer: " object))))

(define (parse-optional-object port)
  (let ((terminator (skip-whitespace port)))
    (if (or (eof-object? terminator)
	    (eq? #\newline terminator))
	#f
	(let ((object (read port)))
	  (if (eof-object? object)
	      #f
	      object)))))

;;;; Command tables

(define (lookup-command name)
  (let loop ((table command-table) (strings name))
    (let ((value (command-table-value table (car strings))))
      (cond ((or (not value) (null? (cdr strings))) value)
	    ((command-table? value) (loop value (cdr strings)))
	    (else #f)))))

(define (command-table-value table string)
  (let ((entry (command-table-entry table string)))
    (and entry
	 (caddr entry))))

(define (command-table-entry table string)
  (let loop ((entries (command-table-entries table)))
    (and (not (null? entries))
	 (let ((entry (car entries)))
	   (if (and (<= (cadr entry)
			(string-length string)
			(string-length (car entry)))
		    (= (string-length string)
		       (match-strings (car entry) string)))
	       entry
	       (loop (cdr entries)))))))

(define (match-strings s1 s2)
  (let ((n (min (string-length s1) (string-length s2))))
    (let loop ((i 0))
      (cond ((= i n) i)
	    ((char=? (string-ref s1 i) (string-ref s2 i)) (loop (+ i 1)))
	    (else i)))))

(define (write-command-name name)
  (display (car name))
  (for-each (lambda (string)
	      (write-char #\space)
	      (display string))
	    (cdr name)))

(define (add-command name value table)
  (let loop ((strings name) (table table))
    (let ((entry
	   (or (let loop ((entries (command-table-entries table)))
		 (and (not (null? entries))
		      (if (string=? (car strings) (caar entries))
			  (car entries)
			  (loop (cdr entries)))))
	       (let ((entry (list (car strings) #f #f)))
		 (let ((entries
			(let ((entries (command-table-entries table)))
			  (if (or (null? entries)
				  (string<? (car strings) (caar entries)))
			      (cons entry entries)
			      (begin
				(let loop ((prev entries) (this (cdr entries)))
				  (if (or (null? this)
					  (string<? (car strings) (caar this)))
				      (set-cdr! prev (cons entry this))
				      (loop this (cdr this))))
				entries)))))
		   (compute-string-abbreviations! entries)
		   (set-command-table-entries! table entries))
		 entry))))
      (if (null? (cdr strings))
	  (set-car! (cddr entry) value)
	  (loop (cdr strings)
		(if (command-table? (caddr entry))
		    (caddr entry)
		    (let ((table (make-command-table '())))
		      (set-car! (cddr entry) table)
		      table)))))))

(define (canonicalize-command-name name)
  (cond ((and (string? name)
	      (not (string-null? name)))
	 (list name))
	((let loop ((name name))
	   (and (pair? name)
		(string? (car name))
		(not (string-null? (car name)))
		(or (null? (cdr name))
		    (loop (cdr name)))))
	 name)
	(else
	 (error "Illegal command name: " name))))

(define (compute-string-abbreviations! entries)
  (let loop ((entries entries) (index 0))
    (let ((groups '()))
      (for-each
       (lambda (entry)
	 (let* ((char (string-ref (car entry) index))
		(group (assv char groups)))
	   (if group
	       (set-cdr! group (cons entry (cdr group)))
	       (set! groups
		     (cons (list char entry)
			   groups)))))
       entries)
      (for-each
       (lambda (group)
	 (let ((index (+ index 1)))
	   (if (null? (cddr group))
	       (set-car! (cdadr group) index)
	       (loop (let ((entry
			    (let loop ((entries (cdr group)))
			      (and (not (null? entries))
				   (if (= index (string-length (caar entries)))
				       (car entries)
				       (loop (cdr entries)))))))
		       (if entry
			   (begin
			     (set-car! (cdr entry) index)
			     (delq entry (cdr group)))
			   (cdr group)))
		     index))))
       groups))))

;;;; Data structures

(define command-table-rtd (make-record-type "command-table" '(entries)))
(define make-command-table (record-constructor command-table-rtd '(entries)))
(define command-table? (record-predicate command-table-rtd))
(define command-table-entries (record-accessor command-table-rtd 'entries))
(define set-command-table-entries!
  (record-modifier command-table-rtd 'entries))

(define command-rtd
  (make-record-type "command"
		    '(name parser documentation procedure)))

(define make-command
  (record-constructor command-rtd
		      '(name parser documentation procedure)))

(define command? (record-predicate command-rtd))
(define command-name (record-accessor command-rtd 'name))
(define command-parser (record-accessor command-rtd 'parser))
(define command-documentation (record-accessor command-rtd 'documentation))
(define command-procedure (record-accessor command-rtd 'procedure))

;;;; Character parsing

(define (read-token port)
  (letrec
      ((loop
	(lambda (chars)
	  (let ((char (peek-char port)))
	    (cond ((eof-object? char)
		   (do-eof char chars))
		  ((char=? #\newline char)
		   (do-eot chars))
		  ((char-whitespace? char)
		   (do-eot chars))
		  ((char=? #\# char)
		   (read-char port)
		   (let ((terminator (skip-comment port)))
		     (if (eof-object? char)
			 (do-eof char chars)
			 (do-eot chars))))
		  (else
		   (read-char port)
		   (loop (cons char chars)))))))
       (do-eof
	(lambda (eof chars)
	  (if (null? chars)
	      eof
	      (do-eot chars))))
       (do-eot
	(lambda (chars)
	  (if (null? chars)
	      #f
	      (list->string (reverse! chars))))))
    (skip-whitespace port)
    (loop '())))

(define (skip-whitespace port)
  (let ((char (peek-char port)))
    (cond ((or (eof-object? char)
	       (char=? #\newline char))
	   char)
	  ((char-whitespace? char)
	   (read-char port)
	   (skip-whitespace port))
	  ((char=? #\# char)
	   (read-char port)
	   (skip-comment port))
	  (else char))))

(define (skip-comment port)
  (let ((char (peek-char port)))
    (if (or (eof-object? char)
	    (char=? #\newline char))
	char
	(begin
	  (read-char port)
	  (skip-comment port)))))

(define (read-rest-of-line port)
  (let loop ((chars '()))
    (let ((char (read-char port)))
      (if (or (eof-object? char)
	      (char=? #\newline char))
	  (list->string (reverse! chars))
	  (loop (cons char chars))))))

(define (discard-rest-of-line port)
  (let loop ()
    (if (not (let ((char (read-char port)))
	       (or (eof-object? char)
		   (char=? #\newline char))))
	(loop))))

;;;; Commands

(define command-table (make-command-table '()))

(define-command "help" 'tokens
  (lambda (state tokens)
    "Type \"help\" followed by a command name for full documentation."
    (let loop ((name (if (null? tokens) '("help") tokens)))
      (let ((value (lookup-command name)))
	(cond ((not value)
	       (write-command-name name)
	       (display " is not a known command name.")
	       (newline))
	      ((command? value)
	       (display (command-documentation value))
	       (newline)
	       (if (equal? '("help") (command-name value))
		   (begin
		     (display "Available commands are:")
		     (newline)
		     (for-each (lambda (entry)
				 (if (not (list? (caddr entry)))
				     (begin
				       (display "  ")
				       (display (car entry))
				       (newline))))
			       (command-table-entries command-table)))))
	      ((command-table? value)
	       (display "The \"")
	       (write-command-name name)
	       (display "\" command requires a subcommand.")
	       (newline)
	       (display "Available subcommands are:")
	       (newline)
	       (for-each (lambda (entry)
			   (if (not (list? (caddr entry)))
			       (begin
				 (display "  ")
				 (write-command-name name)
				 (write-char #\space)
				 (display (car entry))
				 (newline))))
			 (command-table-entries value)))
	      ((list? value)
	       (loop value))
	      (else
	       (error "Unknown value from lookup-command:" value)))))
    state))

(define-command "frame" '('optional exact-nonnegative-integer) debugger:frame)

(define-command "position" '() debugger:position)

(define-command "up" '('optional exact-integer) debugger:up)

(define-command "down" '('optional exact-integer) debugger:down)

(define-command "backtrace" '('optional exact-integer) debugger:backtrace)

(define-command "evaluate" '(object) debugger:evaluate)

(define-command '("info" "args") '() debugger:info-args)

(define-command '("info" "frame") '() debugger:info-frame)

(define-command "quit" '()
  (lambda (state)
    "Exit the debugger."
    (debugger-command-loop-quit)))

(define-command-alias "f" "frame")
(define-command-alias '("info" "f") '("info" "frame"))
(define-command-alias "bt" "backtrace")
(define-command-alias "where" "backtrace")
(define-command-alias "p" "evaluate")
(define-command-alias '("info" "stack") "backtrace")


code:
;;;; (ice-9 debugger commands) -- debugger commands

;;; Copyright (C) 2002, 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 2.1 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

(define-module (ice-9 debugger commands)
  #:use-module (ice-9 debug)
  #:use-module (ice-9 debugger)
  #:use-module (ice-9 debugger state)
  #:use-module (ice-9 debugger utils)
  #:export (backtrace
	    evaluate
	    info-args
	    info-frame
	    position
	    up
	    down
	    frame))

(define (backtrace state n-frames)
  "Print backtrace of all stack frames, or innermost COUNT frames.
With a negative argument, print outermost -COUNT frames.
If the number of frames isn't explicitly given, the debug option
`depth' determines the maximum number of frames printed."
  (let ((stack (state-stack state)))
    ;; Kludge around lack of call-with-values.
    (let ((values
	   (lambda (start end)
	     (display-backtrace stack
				(current-output-port)
				(if (memq 'backwards (debug-options))
				    start
				    (- end 1))
				(- end start))
	     )))
      (let ((end (stack-length stack)))
	(cond ((not n-frames) ;(>= (abs n-frames) end))
	       (values 0 (min end (cadr (memq 'depth (debug-options))))))
	      ((>= n-frames 0)
	       (values 0 n-frames))
	      (else
	       (values (+ end n-frames) end)))))))

(define (eval-handler key . args)
  (let ((stack (make-stack #t eval-handler)))
    (if (= (length args) 4)
	(apply display-error stack (current-error-port) args)
	;; We want display-error to be the "final common pathway"
	(catch #t
	       (lambda ()
		 (apply bad-throw key args))
	       (lambda (key . args)
		 (apply display-error stack (current-error-port) args)))))
  (throw 'continue))

(define (evaluate state expression)
  "Evaluate an expression in the environment of the selected stack frame.
The expression must appear on the same line as the command, however it
may be continued over multiple lines."
  (let ((source (frame-source (stack-ref (state-stack state)
					 (state-index state)))))
    (if (not source)
	(display "No environment for this frame.\n")
	(catch 'continue
	       (lambda ()
		 (lazy-catch #t
			     (lambda ()
			       (let* ((expr
				       ;; We assume that no one will
				       ;; really want to evaluate a
				       ;; string (since it is
				       ;; self-evaluating); so if we
				       ;; have a string here, read the
				       ;; expression to evaluate from
				       ;; it.
				       (if (string? expression)
					   (with-input-from-string expression
								   read)
					   expression))
				      (env (memoized-environment source))
				      (value (local-eval expr env)))
				 (write expr)
				 (display " => ")
				 (write value)
				 (newline)))
			     eval-handler))
	       (lambda args args)))))

(define (info-args state)
  "Display the argument variables of the current stack frame.
Arguments can also be seen in the backtrace, but are presented more
clearly by this command."
  (let ((index (state-index state)))
    (let ((frame (stack-ref (state-stack state) index)))
      (write-frame-index-long frame)
      (write-frame-args-long frame))))

(define (info-frame state)
  "Display a verbose description of the selected frame.  The
information that this command provides is equivalent to what can be
deduced from the one line summary for the frame that appears in a
backtrace, but is presented and explained more clearly."
  (write-state-long state))

(define (position state)
  "Display the name of the source file that the current expression
comes from, and the line and column number of the expression's opening
parenthesis within that file.  This information is only available when
the 'positions read option is enabled."
  (let* ((frame (stack-ref (state-stack state) (state-index state)))
	 (source (frame-source frame)))
    (if (not source)
	(display "No source available for this frame.")
	(let ((position (source-position source)))
	  (if (not position)
	      (display "No position information available for this frame.")
	      (display-position position)))))
  (newline))

(define (up state n)
  "Move @var{n} frames up the stack.  For positive @var{n}, this
advances toward the outermost frame, to lower frame numbers, to
frames that have existed longer.  @var{n} defaults to one."
  (set-stack-index! state (+ (state-index state) (or n 1)))
  (write-state-short state))

(define (down state n)
  "Move @var{n} frames down the stack.  For positive @var{n}, this
advances toward the innermost frame, to higher frame numbers, to frames
that were created more recently.  @var{n} defaults to one."
  (set-stack-index! state (- (state-index state) (or n 1)))
  (write-state-short state))

(define (frame state n)
  "Select and print a stack frame.
With no argument, print the selected stack frame.  (See also \"info frame\").
An argument specifies the frame to select; it must be a stack-frame number."
  (if n (set-stack-index! state (frame-number->index n (state-stack state))))
  (write-state-short state))

;;; (ice-9 debugger commands) ends here.


code:
;;;; (ice-9 debugger state) -- debugger state representation

;;; Copyright (C) 2002, 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 2.1 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

(define-module (ice-9 debugger state)
  #:export (make-state
	    state-stack
	    state-index
	    state-flags
	    set-stack-index!))

(define state-rtd (make-record-type "debugger-state" '(stack index flags)))
(define state? (record-predicate state-rtd))
(define make-state
  (let ((make-state-internal (record-constructor state-rtd
						 '(stack index flags))))
    (lambda (stack index . flags)
      (make-state-internal stack index flags))))
(define state-stack (record-accessor state-rtd 'stack))
(define state-index (record-accessor state-rtd 'index))
(define state-flags (record-accessor state-rtd 'flags))

(define set-state-index! (record-modifier state-rtd 'index))

(define (set-stack-index! state index)
  (let* ((stack (state-stack state))
	 (ssize (stack-length stack)))
    (set-state-index! state
		      (cond ((< index 0) 0)
			    ((>= index ssize) (- ssize 1))
			    (else index)))))

;;; (ice-9 debugger state) ends here.


code:
;;;; (ice-9 debugger trc) -- tracing for Guile debugger code

;;; Copyright (C) 2002, 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 2.1 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

(define-module (ice-9 debugger trc)
  #:export (trc trc-syms trc-all trc-none trc-add trc-remove trc-port))

(define *syms* #f)

(define (trc-set! syms)
  (set! *syms* syms))

(define (trc-syms . syms)
  (trc-set! syms))

(define (trc-all)
  (trc-set! #f))

(define (trc-none)
  (trc-set! '()))

(define (trc-add sym)
  (trc-set! (cons sym *syms*)))

(define (trc-remove sym)
  (trc-set! (delq1! sym *syms*)))

(define (trc sym . args)
  (if (or (not *syms*)
	  (memq sym *syms*))
      (let ((port (trc-port)))
	(write sym port)
	(display ":" port)
	(for-each (lambda (arg)
		    (display " " port)
		    (write arg port))
		  args)
	(newline port))))

(define trc-port
  (let ((port (current-error-port)))
    (make-procedure-with-setter
     (lambda () port)
     (lambda (p) (set! port p)))))

;; Default to no tracing.
(trc-none)

;;; (ice-9 debugger trc) ends here.


code:
(define-module (ice-9 debugger utils)
  #:use-module (ice-9 debugger state)
  #:export (display-position
	    source-position
	    write-frame-args-long
	    write-frame-index-long
	    write-frame-short/expression
	    write-frame-short/application
	    write-frame-long
	    write-state-long
	    write-state-short))

;;; Procedures in this module print information about a stack frame.
;;; The available information is as follows.
;;;
;;; * Source code location.
;;;
;;; For an evaluation frame, this is the location recorded at the time
;;; that the expression being evaluated was read, if the 'positions
;;; read option was enabled at that time.
;;;
;;; For an application frame, I'm not yet sure.  Some applications
;;; seem to have associated source expressions.
;;;
;;; * Whether frame is still evaluating its arguments.
;;;
;;; Only applies to an application frame.  For example, an expression
;;; like `(+ (* 2 3) 4)' goes through the following stages of
;;; evaluation.
;;;
;;; (+ (* 2 3) 4)       -- evaluation
;;; [+ ...              -- application; the car of the evaluation
;;;                        has been evaluated and found to be a
;;;                        procedure; before this procedure can
;;;                        be applied, its arguments must be evaluated
;;; [+ 6 ...            -- same application after evaluating the
;;;                        first argument
;;; [+ 6 4]             -- same application after evaluating all
;;;                        arguments
;;; 10                  -- result
;;;
;;; * Whether frame is real or tail-recursive.
;;;
;;; If a frame is tail-recursive, its containing frame as shown by the
;;; debugger backtrace doesn't really exist as far as the Guile
;;; evaluator is concerned.  The effect of this is that when a
;;; tail-recursive frame returns, it looks as though its containing
;;; frame returns at the same time.  (And if the containing frame is
;;; also tail-recursive, _its_ containing frame returns at that time
;;; also, and so on ...)
;;;
;;; A `real' frame is one that is not tail-recursive.

(define (write-state-short state)
  (let* ((frame (stack-ref (state-stack state) (state-index state)))
	 (source (frame-source frame))
	 (position (and source (source-position source))))
    (format #t "Frame ~A at " (frame-number frame))
    (if position
	(display-position position)
	(display "unknown source location"))
    (newline)
    (write-char #\tab)
    (write-frame-short frame)
    (newline)))

(define (write-state-short* stack index)
  (write-frame-index-short stack index)
  (write-char #\space)
  (write-frame-short (stack-ref stack index))
  (newline))

(define (write-frame-index-short stack index)
  (let ((s (number->string (frame-number (stack-ref stack index)))))
    (display s)
    (write-char #\:)
    (write-chars #\space (- 4 (string-length s)))))

(define (write-frame-short frame)
  (if (frame-procedure? frame)
      (write-frame-short/application frame)
      (write-frame-short/expression frame)))

(define (write-frame-short/application frame)
  (write-char #\[)
  (write (let ((procedure (frame-procedure frame)))
	   (or (and (procedure? procedure)
		    (procedure-name procedure))
	       procedure)))
  (if (frame-evaluating-args? frame)
      (display " ...")
      (begin
	(for-each (lambda (argument)
		    (write-char #\space)
		    (write argument))
		  (frame-arguments frame))
	(write-char #\]))))

;;; Use builtin function instead:
(set! write-frame-short/application
      (lambda (frame)
	(display-application frame (current-output-port) 12)))

(define (write-frame-short/expression frame)
  (write (let* ((source (frame-source frame))
		(copy (source-property source 'copy)))
	   (if (pair? copy)
	       copy
	       (unmemoize-expr source)))))

(define (write-state-long state)
  (let ((index (state-index state)))
    (let ((frame (stack-ref (state-stack state) index)))
      (write-frame-index-long frame)
      (write-frame-long frame))))

(define (write-frame-index-long frame)
  (display "Stack frame: ")
  (write (frame-number frame))
  (if (frame-real? frame)
      (display " (real)"))
  (newline))

(define (write-frame-long frame)
  (if (frame-procedure? frame)
      (write-frame-long/application frame)
      (write-frame-long/expression frame)))

(define (write-frame-long/application frame)
  (display "This frame is an application.")
  (newline)
  (if (frame-source frame)
      (begin
	(display "The corresponding expression is:")
	(newline)
	(display-source frame)
	(newline)))
  (display "The procedure being applied is: ")
  (write (let ((procedure (frame-procedure frame)))
	   (or (and (procedure? procedure)
		    (procedure-name procedure))
	       procedure)))
  (newline)
  (display "The procedure's arguments are")
  (if (frame-evaluating-args? frame)
      (display " being evaluated.")
      (begin
	(display ": ")
	(write (frame-arguments frame))))
  (newline))

(define (display-source frame)
  (let* ((source (frame-source frame))
	 (copy (source-property source 'copy)))
    (cond ((source-position source)
	   => (lambda (p) (display-position p) (display ":\n"))))
    (display "  ")
    (write (or copy (unmemoize-expr source)))))

(define (source-position source)
  (let ((fname (source-property source 'filename))
	(line (source-property source 'line))
	(column (source-property source 'column)))
    (and fname
	 (list fname line column))))

(define (display-position pos)
  (format #t "~A:~D:~D" (car pos) (+ 1 (cadr pos)) (+ 1 (caddr pos))))

(define (write-frame-long/expression frame)
  (display "This frame is an evaluation.")
  (newline)
  (display "The expression being evaluated is:")
  (newline)
  (display-source frame)
  (newline))

(define (write-frame-args-long frame)
  (if (frame-procedure? frame)
      (let ((arguments (frame-arguments frame)))
	(let ((n (length arguments)))
	  (display "This frame has ")
	  (write n)
	  (display " argument")
	  (if (not (= n 1))
	      (display "s"))
	  (write-char (if (null? arguments) #\. #\:))
	  (newline))
	(for-each (lambda (argument)
		    (display "  ")
		    (write argument)
		    (newline))
		  arguments))
      (begin
	(display "This frame is an evaluation frame; it has no arguments.")
	(newline))))

(define (write-chars char n)
  (do ((i 0 (+ i 1)))
      ((>= i n))
    (write-char char)))


code:
(define-module (ice-9 debugging example-fns)
  #:export (fact1 fact2 facti))

(define (fact1 n)
  (if (= n 0)
      1
      (* n (fact1 (- n 1)))))

(define (facti n a)
  (if (= n 0)
      a
      (facti (- n 1) (* a n))))

(define (fact2 n)
  (facti n 1))

; Test: (fact2 3)


code:
(define-module (ice-9 debugging ice-9-debugger-extensions)
  #:use-module (ice-9 debugger))

;;; Upgrade the debugger state object so that it can carry a flag
;;; indicating whether the debugging session is continuable.

(cond ((string>=? (version) "1.7")
       (use-modules (ice-9 debugger state))
       (define-module (ice-9 debugger state)))
      (else
       (define-module (ice-9 debugger))))

(set! state-rtd (make-record-type "debugger-state" '(stack index flags)))
(set! state? (record-predicate state-rtd))
(set! make-state
  (let ((make-state-internal (record-constructor state-rtd
						 '(stack index flags))))
    (lambda (stack index . flags)
      (make-state-internal stack index flags))))
(set! state-stack (record-accessor state-rtd 'stack))
(set! state-index (record-accessor state-rtd 'index))

(define state-flags (record-accessor state-rtd 'flags))

;;; Add commands that (ice-9 debugger) doesn't currently have, for
;;; continuing or single stepping program execution.

(cond ((string>=? (version) "1.7")
       (use-modules (ice-9 debugger command-loop))
       (define-module (ice-9 debugger command-loop)
	 #:use-module (ice-9 debugger)
	 #:use-module (ice-9 debugger state)
	 #:use-module (ice-9 debugging traps))
       (define new-define-command define-command)
       (set! define-command
	     (lambda (name argument-template documentation procedure)
	       (new-define-command name argument-template procedure))))
      (else
       (define-module (ice-9 debugger))))

(use-modules (ice-9 debugging steps)
             (ice-9 debugging trace))

(define (assert-continuable state)
  ;; Check that debugger is in a state where `continuing' makes sense.
  ;; If not, signal an error.
  (or (memq #:continuable (state-flags state))
      (user-error "This debug session is not continuable.")))

(define (debugger:continue state)
  "Tell the program being debugged to continue running.  (In fact this is
the same as the @code{quit} command, because it exits the debugger
command loop and so allows whatever code it was that invoked the
debugger to continue.)"
  (assert-continuable state)
  (throw 'exit-debugger))

(define (debugger:finish state)
  "Continue until evaluation of the current frame is complete, and
print the result obtained."
  (assert-continuable state)
  (at-exit (- (stack-length (state-stack state))
	      (state-index state))
	   (list trace-trap debug-trap))
  (debugger:continue state))

(define (debugger:step state n)
  "Tell the debugged program to do @var{n} more steps from its current
position.  One @dfn{step} means executing until the next frame entry
or exit of any kind.  @var{n} defaults to 1."
  (assert-continuable state)
  (at-step debug-trap (or n 1))
  (debugger:continue state))

(define (debugger:next state n)
  "Tell the debugged program to do @var{n} more steps from its current
position, but only counting frame entries and exits where the
corresponding source code comes from the same file as the current
stack frame.  (See @ref{Step Traps} for the details of how this
works.)  If the current stack frame has no source code, the effect of
this command is the same as of @code{step}.  @var{n} defaults to 1."
  (assert-continuable state)
  (at-step debug-trap
	   (or n 1)
	   (frame-file-name (stack-ref (state-stack state)
				       (state-index state)))
	   (if (memq #:return (state-flags state))
	       #f
	       (- (stack-length (state-stack state)) (state-index state))))
  (debugger:continue state))

(define-command "continue" '()
  "Continue program execution."
  debugger:continue)

(define-command "finish" '()
  "Continue until evaluation of the current frame is complete, and
print the result obtained."
  debugger:finish)

(define-command "step" '('optional exact-integer)
  "Continue until entry to @var{n}th next frame."
  debugger:step)

(define-command "next" '('optional exact-integer)
  "Continue until entry to @var{n}th next frame in same file."
  debugger:next)

;;; Export a couple of procedures for use by (ice-9 debugging trace).

(cond ((string>=? (version) "1.7"))
      (else
       (define-module (ice-9 debugger))
       (export write-frame-short/expression
	       write-frame-short/application)))

;;; Provide a `debug-trap' entry point in (ice-9 debugger).  This is
;;; designed so that it can be called to explore the stack at a
;;; breakpoint, and to single step from the breakpoint.

(define-module (ice-9 debugger))

(use-modules (ice-9 debugging traps))

(define *not-yet-introduced* #t)

(cond ((string>=? (version) "1.7"))
      (else
       (define (debugger-command-loop state)
	 (read-and-dispatch-commands state (current-input-port)))))

(define-public (debug-trap trap-context)
  "Invoke the Guile debugger to explore the stack at the specified @var{trap}."
  (start-stack 'debugger
	       (let* ((stack (tc:stack trap-context))
		      (flags1 (let ((trap-type (tc:type trap-context)))
				(case trap-type
				  ((#:return #:error)
				   (list trap-type
					 (tc:return-value trap-context)))
				  (else
				   (list trap-type)))))
		      (flags (if (tc:continuation trap-context)
				 (cons #:continuable flags1)
				 flags1))
		      (state (apply make-state stack 0 flags)))
		 (if *not-yet-introduced*
		     (let ((ssize (stack-length stack)))
		       (display "This is the Guile debugger -- for help, type `help'.\n")
		       (set! *not-yet-introduced* #f)
		       (if (= ssize 1)
			   (display "There is 1 frame on the stack.\n\n")
			   (format #t "There are ~A frames on the stack.\n\n" ssize))))
		 (write-state-short-with-source-location state)
		 (debugger-command-loop state))))

(define write-state-short-with-source-location
  (cond ((string>=? (version) "1.7")
	 write-state-short)
	(else
	 (lambda (state)
	   (let* ((frame (stack-ref (state-stack state) (state-index state)))
		  (source (frame-source frame))
		  (position (and source (source-position source))))
	     (format #t "Frame ~A at " (frame-number frame))
	     (if position
		 (display-position position)
		 (display "unknown source location"))
	     (newline)
	     (write-char #\tab)
	     (write-frame-short frame)
	     (newline))))))


code:
;;;; (ice-9 debugging steps) -- stepping through code from the debugger

;;; Copyright (C) 2002, 2004 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 2.1 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

(define-module (ice-9 debugging steps)
  #:use-module (ice-9 debugging traps)
  #:use-module (ice-9 and-let-star)
  #:use-module (ice-9 debugger)
  #:use-module (ice-9 optargs)
  #:export (at-exit
	    at-entry
	    at-apply
	    at-step
	    at-next))

;;; at-exit DEPTH BEHAVIOUR
;;;
;;; Install a behaviour to run when we exit the current frame.

(define (at-exit depth behaviour)
  (install-trap (make <exit-trap>
		  #:depth depth
		  #:single-shot #t
		  #:behaviour behaviour)))

;;; at-entry BEHAVIOUR [COUNT]
;;;
;;; Install a behaviour to run when we get to the COUNT'th next frame
;;; entry.  COUNT defaults to 1.

(define* (at-entry behaviour #:optional (count 1))
  (install-trap (make <entry-trap>
		  #:skip-count (- count 1)
		  #:single-shot #t
		  #:behaviour behaviour)))

;;; at-apply BEHAVIOUR [COUNT]
;;;
;;; Install a behaviour to run when we get to the COUNT'th next
;;; application.  COUNT defaults to 1.

(define* (at-apply behaviour #:optional (count 1))
  (install-trap (make <apply-trap>
		  #:skip-count (- count 1)
		  #:single-shot #t
		  #:behaviour behaviour)))

;;; at-step BEHAVIOUR [COUNT [FILENAME [DEPTH]]
;;;
;;; Install BEHAVIOUR to run on the COUNT'th next application, frame
;;; entry or frame exit.  COUNT defaults to 1.  If FILENAME is
;;; specified and not #f, only frames that begin in the named file are
;;; counted.

(define* (at-step behaviour #:optional (count 1) filename (depth 1000))
  (install-trap (make <step-trap>
		  #:file-name filename
		  #:exit-depth depth
		  #:skip-count (- count 1)
		  #:single-shot #t
		  #:behaviour behaviour)))

;;  (or count (set! count 1))
;;  (letrec ((proc (lambda (trap-context)
;;		   ;; Behaviour whenever we enter or exit a frame.
;;		   (set! count (- count 1))
;;		   (if (= count 0)
;;		       (begin
;;			 (remove-enter-frame-hook! step)
;;			 (remove-apply-frame-hook! step)
;;			 (behaviour trap-context)))))
;;	   (step (lambda (trap-context)
;;		   ;; Behaviour on frame entry: both execute the above
;;		   ;; and install it as an exit hook.
;;		   (if (or (not filename)
;;			   (equal? (frame-file-name (tc:frame trap-context))
;;                                   filename))
;;		       (begin
;;			 (proc trap-context)
;;			 (at-exit (tc:depth trap-context) proc))))))
;;    (at-exit depth proc)
;;    (add-enter-frame-hook! step)
;;    (add-apply-frame-hook! step)))

;;; at-next BEHAVIOUR [COUNT]
;;;
;;; Install a behaviour to run when we get to the COUNT'th next frame
;;; entry in the same source file as the current location.  COUNT
;;; defaults to 1.  If the current location has no filename, fall back
;;; silently to `at-entry' behaviour.

;;; (ice-9 debugging steps) ends here.


code:
;;;; (ice-9 debugging trace) -- breakpoint trace behaviour

;;; Copyright (C) 2002 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 2.1 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

(define-module (ice-9 debugging trace)
  #:use-module (ice-9 debug)
  #:use-module (ice-9 debugger)
  #:use-module (ice-9 debugging ice-9-debugger-extensions)
  #:use-module (ice-9 debugging steps)
  #:use-module (ice-9 debugging traps)
  #:export (trace-trap
	    trace-port
	    set-trace-layout
            trace/pid
            trace/stack-id
            trace/stack-depth
            trace/stack-real-depth
            trace/stack
            trace/source-file-name
            trace/source-line
            trace/source-column
            trace/source
            trace/type
            trace/real?
            trace/info
	    trace-at-exit
	    trace-until-exit))

(cond ((string>=? (version) "1.7")
       (use-modules (ice-9 debugger utils))))

(define trace-format-string #f)
(define trace-arg-procs #f)

(define (set-trace-layout format-string . arg-procs)
  (set! trace-format-string format-string)
  (set! trace-arg-procs arg-procs))

(define (trace/pid trap-context)
  (getpid))

(define (trace/stack-id trap-context)
  (stack-id (tc:stack trap-context)))

(define (trace/stack-depth trap-context)
  (tc:depth trap-context))

(define (trace/stack-real-depth trap-context)
  (tc:real-depth trap-context))

(define (trace/stack trap-context)
  (format #f "~a:~a+~a"
	  (stack-id (tc:stack trap-context))
	  (tc:real-depth trap-context)
	  (- (tc:depth trap-context) (tc:real-depth trap-context))))

(define (trace/source-file-name trap-context)
  (cond ((frame->source-position (tc:frame trap-context)) => car)
	(else "")))

(define (trace/source-line trap-context)
  (cond ((frame->source-position (tc:frame trap-context)) => cadr)
	(else 0)))

(define (trace/source-column trap-context)
  (cond ((frame->source-position (tc:frame trap-context)) => caddr)
	(else 0)))

(define (trace/source trap-context)
  (cond ((frame->source-position (tc:frame trap-context))
	 =>
	 (lambda (pos)
	   (format #f "~a:~a:~a" (car pos) (cadr pos) (caddr pos))))
	(else "")))

(define (trace/type trap-context)
  (case (tc:type trap-context)
    ((#:application) "APP")
    ((#:evaluation) "EVA")
    ((#:return) "RET")
    ((#:error) "ERR")
    (else "???")))

(define (trace/real? trap-context)
  (if (frame-real? (tc:frame trap-context)) " " "t"))

(define (trace/info trap-context)
  (with-output-to-string
    (lambda ()
      (if (memq (tc:type trap-context) '(#:application #:evaluation))
	  ((if (tc:expression trap-context)
	       write-frame-short/expression
	       write-frame-short/application) (tc:frame trap-context))
	  (begin
	    (display "=>")
	    (write (tc:return-value trap-context)))))))

(set-trace-layout "|~3@a: ~a\n" trace/stack-real-depth trace/info)

;;; trace-trap
;;;
;;; Trace the current location, and install a hook to trace the return
;;; value when we exit the current frame.

(define (trace-trap trap-context)
  (apply format
	 (trace-port)
	 trace-format-string
	 (map (lambda (arg-proc)
		(arg-proc trap-context))
	      trace-arg-procs)))

(set! (behaviour-ordering trace-trap) 50)

;;; trace-port
;;;
;;; The port to which trace information is printed.

(define trace-port
  (let ((port (current-output-port)))
    (make-procedure-with-setter
     (lambda () port)
     (lambda (new) (set! port new)))))

;;; trace-at-exit
;;;
;;; Trace return value on exit from the current frame.

(define (trace-at-exit trap-context)
  (at-exit (tc:depth trap-context) trace-trap))

;;; trace-until-exit
;;;
;;; Trace absolutely everything until exit from the current frame.

(define (trace-until-exit trap-context)
  (let ((step-trap (make <step-trap> #:behaviour trace-trap)))
    (install-trap step-trap)
    (at-exit (tc:depth trap-context)
	     (lambda (trap-context)
	       (uninstall-trap step-trap)))))

;;; (ice-9 debugging trace) ends here.