code:
;;;; (ice-9 debugging traps) -- abstraction of libguile's traps interface

;;; Copyright (C) 2002, 2004 Free Software Foundation, Inc.
;;; Copyright (C) 2005 Neil Jerram
;;;
;; 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

;;; This module provides an abstraction around Guile's low level trap
;;; handler interface; its aim is to make the low level trap mechanism
;;; shareable between the debugger and other applications, and to
;;; insulate the rest of the debugger code a bit from changes that may
;;; occur in the low level trap interface in future.

(define-module (ice-9 debugging traps)
  #:use-module (ice-9 regex)
  #:use-module (oop goops)
  #:use-module (oop goops describe)
  #:use-module (ice-9 debugging trc)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-2)
  #:export (tc:type
            tc:continuation
            tc:expression
            tc:return-value
            tc:stack
            tc:frame
            tc:depth
            tc:real-depth
            tc:exit-depth
	    tc:fired-traps
	    ;; Interface for users of <trap> subclasses defined in
	    ;; this module.
            add-trapped-stack-id!
	    remove-trapped-stack-id!
	    <procedure-trap>
	    <exit-trap>
	    <entry-trap>
	    <apply-trap>
	    <step-trap>
	    <source-trap>
	    <location-trap>
	    install-trap
	    uninstall-trap
            all-traps
            get-trap
	    list-traps
	    trap-ordering
            behaviour-ordering
	    throw->trap-context
	    on-lazy-handler-dispatch
	    ;; Interface for authors of new <trap> subclasses.
	    <trap-context>
	    <trap>
	    trap->behaviour
	    trap-runnable?
	    install-apply-frame-trap
	    install-breakpoint-trap
	    install-enter-frame-trap
	    install-exit-frame-trap
	    install-trace-trap
	    uninstall-apply-frame-trap
	    uninstall-breakpoint-trap
	    uninstall-enter-frame-trap
	    uninstall-exit-frame-trap
	    uninstall-trace-trap
	    frame->source-position
	    frame-file-name
	    without-traps
            guile-trap-features)
  #:re-export (make)
  #:export-syntax (trap-here))

;; How to debug the debugging infrastructure, when needed.  Grep for
;; "(trc " to find other symbols that can be passed to trc-add.
;; (trc-add 'after-gc-hook)

;; In Guile 1.7 onwards, weak-vector and friends are provided by the
;; (ice-9 weak-vector) module.
(cond ((string>=? (version) "1.7")
       (use-modules (ice-9 weak-vector))))

;;; The current low level traps interface is as follows.
;;;
;;; All trap handlers are subject to SCM_TRAPS_P, which is controlled
;;; by the `traps' setting of `(evaluator-traps-interface)' but also
;;; (and more relevant in most cases) by the `with-traps' procedure.
;;; Basically, `with-traps' sets SCM_TRAPS_P to 1 during execution of
;;; its thunk parameter.
;;;
;;; Note that all trap handlers are called with SCM_TRAPS_P set to 0
;;; for the duration of the call, to avoid nasty recursive trapping
;;; loops.  If a trap handler knows what it is doing, it can override
;;; this by `(trap-enable traps)'.
;;;
;;; The apply-frame handler is called when Guile is about to perform
;;; an application if EITHER the `apply-frame' evaluator trap option
;;; is set, OR the `trace' debug option is set and the procedure to
;;; apply has its `trace' procedure property set.  The arguments
;;; passed are:
;;;
;;; - the symbol 'apply-frame
;;;
;;; - a continuation or debug object describing the current stack
;;;
;;; - a boolean indicating whether the application is tail-recursive.
;;;
;;; The enter-frame handler is called when the evaluator begins a new
;;; evaluation frame if EITHER the `enter-frame' evaluator trap option
;;; is set, OR the `breakpoints' debug option is set and the code to
;;; be evaluated has its `breakpoint' source property set.  The
;;; arguments passed are:
;;;
;;; - the symbol 'enter-frame
;;;
;;; - a continuation or debug object describing the current stack
;;;
;;; - a boolean indicating whether the application is tail-recursive.
;;;
;;; - an unmemoized copy of the expression to be evaluated.
;;;
;;; If the `enter-frame' evaluator trap option is set, the enter-frame
;;; handler is also called when about to perform an application in
;;; SCM_APPLY, immediately before possibly calling the apply-frame
;;; handler.  (I don't totally understand this.)  In this case, the
;;; arguments passed are:
;;;
;;; - the symbol 'enter-frame
;;;
;;; - a continuation or debug object describing the current stack.
;;;
;;; The exit-frame handler is called when Guile exits an evaluation
;;; frame (in SCM_CEVAL) or an application frame (in SCM_APPLY), if
;;; EITHER the `exit-frame' evaluator trap option is set, OR the
;;; `trace' debug option is set and the frame is marked as having been
;;; traced.  The frame will be marked as having been traced if the
;;; apply-frame handler was called for this frame.  (This is trickier
;;; than it sounds because of tail recursion: the same debug frame
;;; could have been used for multiple applications, only some of which
;;; were traced - I think.)  The arguments passed are:
;;;
;;; - the symbol 'exit-frame
;;;
;;; - a continuation or debug object describing the current stack
;;;
;;; - the result of the evaluation or application.

;;; {Trap Context}
;;;
;;; A trap context is a GOOPS object that encapsulates all the useful
;;; information about a particular trap.  Encapsulating this
;;; information in a single object also allows us:
;;;
;;; - to defer the calculation of information that is time-consuming
;;; to calculate, such as the stack, and to cache such information so
;;; that it is only ever calculated once per trap
;;;
;;; - to pass all interesting information to trap behaviour procedures
;;; in a single parameter, which (i) is convenient and (ii) makes for
;;; a more future-proof interface.
;;;
;;; It also allows us - where very carefully documented! - to pass
;;; information from one behaviour procedure to another.

(define-class <trap-context> ()
  ;; Information provided directly by the trap calls from the
  ;; evaluator.  The "type" slot holds a keyword indicating the type
  ;; of the trap: one of #:evaluation, #:application, #:return,
  ;; #:error.
  (type #:getter tc:type
        #:init-keyword #:type)
  ;; The "continuation" slot holds the continuation (or debug object,
  ;; if "cheap" traps are enabled, which is the default) at the point
  ;; of the trap.  For an error trap it is #f.
  (continuation #:getter tc:continuation
                #:init-keyword #:continuation)
  ;; The "expression" slot holds the source code expression, for an
  ;; evaluation trap.
  (expression #:getter tc:expression
              #:init-keyword #:expression
              #:init-value #f)
  ;; The "return-value" slot holds the return value, for a return
  ;; trap, or the error args, for an error trap.
  (return-value #:getter tc:return-value
                #:init-keyword #:return-value
                #:init-value #f)
  ;; The list of trap objects which fired in this trap context.
  (fired-traps #:getter tc:fired-traps
	       #:init-value '())
  ;; The set of symbols which, if one of them is set in the CAR of the
  ;; handler-return-value slot, will cause the CDR of that slot to
  ;; have an effect.
  (handler-return-syms #:init-value '())
  ;; The value which the trap handler should return to the evaluator.
  (handler-return-value #:init-value #f)
  ;; Calculated and cached information.  "stack" is the stack
  ;; (computed from the continuation (or debug object) by make-stack,
  ;; or else (in the case of an error trap) by (make-stack #t ...).
  (stack #:init-value #f)
  (frame #:init-value #f)
  (depth #:init-value #f)
  (real-depth #:init-value #f)
  (exit-depth #:init-value #f))

(define-method (tc:stack (ctx <trap-context>))
  (or (slot-ref ctx 'stack)
      (let ((stack (make-stack (tc:continuation ctx))))
        (slot-set! ctx 'stack stack)
        stack)))

(define-method (tc:frame (ctx <trap-context>))
  (or (slot-ref ctx 'frame)
      (let ((frame (cond ((tc:continuation ctx) => last-stack-frame)
			 (else (stack-ref (tc:stack ctx) 0)))))
        (slot-set! ctx 'frame frame)
        frame)))

(define-method (tc:depth (ctx <trap-context>))
  (or (slot-ref ctx 'depth)
      (let ((depth (stack-length (tc:stack ctx))))
        (slot-set! ctx 'depth depth)
        depth)))

(define-method (tc:real-depth (ctx <trap-context>))
  (or (slot-ref ctx 'real-depth)
      (let* ((stack (tc:stack ctx))
	     (real-depth (apply +
				(map (lambda (i)
				       (if (frame-real? (stack-ref stack i))
					   1
					   0))
				     (iota (tc:depth ctx))))))
        (slot-set! ctx 'real-depth real-depth)
        real-depth)))

(define-method (tc:exit-depth (ctx <trap-context>))
  (or (slot-ref ctx 'exit-depth)
      (let* ((stack (tc:stack ctx))
	     (depth (tc:depth ctx))
	     (exit-depth (let loop ((exit-depth depth))
			   (if (or (zero? exit-depth)
				   (frame-real? (stack-ref stack
							   (- depth
							      exit-depth))))
			       exit-depth
			       (loop (- exit-depth 1))))))
	(slot-set! ctx 'exit-depth exit-depth)
        exit-depth)))

;;; {Stack IDs}
;;;
;;; Mechanism for limiting trapping to contexts whose stack ID matches
;;; one of a registered set.  The default is for traps to fire
;;; regardless of stack ID.

(define trapped-stack-ids (list #t))
(define all-stack-ids-trapped? #t)

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

(define (remove-trapped-stack-id! id)
  "Remove ID from the set of stack ids for which traps are active."
  (set! trapped-stack-ids (delq1! id trapped-stack-ids))
  (set! all-stack-ids-trapped? (memq #t trapped-stack-ids)))

(define (trap-here? cont)
  ;; Return true if the stack id of the specified continuation (or
  ;; debug object) is in the set that we should trap for; otherwise
  ;; false.
  (or all-stack-ids-trapped?
      (memq (stack-id cont) trapped-stack-ids)))

;;; {Global State}
;;;
;;; Variables tracking registered handlers, relevant procedures, and
;;; what's turned on as regards the evaluator's debugging options.

(define enter-frame-traps '())
(define apply-frame-traps '())
(define exit-frame-traps '())
(define breakpoint-traps '())
(define trace-traps '())

(define (non-null? hook)
  (not (null? hook)))

;; The low level frame handlers must all be initialized to something
;; harmless.  Otherwise we hit a problem immediately when trying to
;; enable one of these handlers.
(trap-set! enter-frame-handler noop)
(trap-set! apply-frame-handler noop)
(trap-set! exit-frame-handler noop)

(define set-debug-and-trap-options
  (let ((dopts (debug-options))
	(topts (evaluator-traps-interface))
	(setting (lambda (key opts)
		   (let ((l (memq key opts)))
		     (and l
			  (not (null? (cdr l)))
			  (cadr l)))))
	(debug-set-boolean! (lambda (key value)
			      ((if value debug-enable debug-disable) key)))
	(trap-set-boolean! (lambda (key value)
			     ((if value trap-enable trap-disable) key))))
    (let ((save-debug (memq 'debug dopts))
	  (save-trace (memq 'trace dopts))
	  (save-breakpoints (memq 'breakpoints dopts))
	  (save-enter-frame (memq 'enter-frame topts))
	  (save-apply-frame (memq 'apply-frame topts))
	  (save-exit-frame (memq 'exit-frame topts))
	  (save-enter-frame-handler (setting 'enter-frame-handler topts))
	  (save-apply-frame-handler (setting 'apply-frame-handler topts))
	  (save-exit-frame-handler (setting 'exit-frame-handler topts)))
      (lambda ()
	(let ((need-trace (non-null? trace-traps))
	      (need-breakpoints (non-null? breakpoint-traps))
	      (need-enter-frame (non-null? enter-frame-traps))
	      (need-apply-frame (non-null? apply-frame-traps))
	      (need-exit-frame (non-null? exit-frame-traps)))
	  (debug-set-boolean! 'debug
			      (or need-trace
				  need-breakpoints
				  need-enter-frame
				  need-apply-frame
				  need-exit-frame
				  save-debug))
	  (debug-set-boolean! 'trace
			      (or need-trace
				  save-trace))
	  (debug-set-boolean! 'breakpoints
			      (or need-breakpoints
				  save-breakpoints))
	  (trap-set-boolean! 'enter-frame
			     (or need-enter-frame
				 save-enter-frame))
	  (trap-set-boolean! 'apply-frame
			     (or need-apply-frame
				 save-apply-frame))
	  (trap-set-boolean! 'exit-frame
			     (or need-exit-frame
				 save-exit-frame))
	  (trap-set! enter-frame-handler
		     (cond ((or need-breakpoints
				need-enter-frame)
			    enter-frame-handler)
			   (else save-enter-frame-handler)))
	  (trap-set! apply-frame-handler
		     (cond ((or need-trace
				need-apply-frame)
			    apply-frame-handler)
			   (else save-apply-frame-handler)))
	  (trap-set! exit-frame-handler
		     (cond ((or need-exit-frame)
			    exit-frame-handler)
			   (else save-exit-frame-handler))))
	;;(write (evaluator-traps-interface))
	*unspecified*))))

(define (enter-frame-handler key cont . args)
  ;; For a non-application entry, ARGS is (TAIL? EXP), where EXP is an
  ;; unmemoized copy of the source expression.  For an application
  ;; entry, ARGS is empty.
  (if (trap-here? cont)
      (let* ((application-entry? (null? args))
             (trap-context (make <trap-context>
                             #:type #:evaluation
                             #:continuation cont
                             #:expression (if application-entry?
                                              #f
                                              (cadr args)))))
	(trc 'enter-frame-handler)
	(if (and (not application-entry?)
                 (memq 'tweaking guile-trap-features))
	    (slot-set! trap-context 'handler-return-syms '(instead)))
        (run-traps (if application-entry?
		       enter-frame-traps
		       (append enter-frame-traps breakpoint-traps))
		   trap-context)
	(slot-ref trap-context 'handler-return-value))))

(define (apply-frame-handler key cont tail?)
  (if (trap-here? cont)
      (let ((trap-context (make <trap-context>
                            #:type #:application
                            #:continuation cont)))
	(trc 'apply-frame-handler tail?)
        (run-traps (append apply-frame-traps trace-traps) trap-context)
	(slot-ref trap-context 'handler-return-value))))

(define (exit-frame-handler key cont retval)
  (if (trap-here? cont)
      (let ((trap-context (make <trap-context>
                            #:type #:return
                            #:continuation cont
                            #:return-value retval)))
	(trc 'exit-frame-handler retval (tc:depth trap-context))
	(if (memq 'tweaking guile-trap-features)
            (slot-set! trap-context 'handler-return-syms '(instead)))
        (run-traps exit-frame-traps trap-context)
	(slot-ref trap-context 'handler-return-value))))

(define-macro (trap-installer trap-list)
  `(lambda (trap)
     (set! ,trap-list (cons trap ,trap-list))
     (set-debug-and-trap-options)))

(define install-enter-frame-trap (trap-installer enter-frame-traps))
(define install-apply-frame-trap (trap-installer apply-frame-traps))
(define install-exit-frame-trap (trap-installer exit-frame-traps))
(define install-breakpoint-trap (trap-installer breakpoint-traps))
(define install-trace-trap (trap-installer trace-traps))

(define-macro (trap-uninstaller trap-list)
  `(lambda (trap)
     (or (memq trap ,trap-list)
         (error "Trap list does not include the specified trap"))
     (set! ,trap-list (delq1! trap ,trap-list))
     (set-debug-and-trap-options)))

(define uninstall-enter-frame-trap (trap-uninstaller enter-frame-traps))
(define uninstall-apply-frame-trap (trap-uninstaller apply-frame-traps))
(define uninstall-exit-frame-trap (trap-uninstaller exit-frame-traps))
(define uninstall-breakpoint-trap (trap-uninstaller breakpoint-traps))
(define uninstall-trace-trap (trap-uninstaller trace-traps))

(define trap-ordering (make-object-property))
(define behaviour-ordering (make-object-property))

(define (run-traps traps trap-context)
  (let ((behaviours (apply append
			   (map (lambda (trap)
				  (trap->behaviour trap trap-context))
				(sort traps
				      (lambda (t1 t2)
					(< (or (trap-ordering t1) 0)
					   (or (trap-ordering t2) 0))))))))
    (for-each (lambda (proc)
		(proc trap-context))
	      (sort (delete-duplicates behaviours)
		    (lambda (b1 b2)
                    (< (or (behaviour-ordering b1) 0)
                       (or (behaviour-ordering b2) 0)))))))

;;; {Pseudo-Traps for Non-Trap Events}

;;; Once there is a body of code to do with responding to (debugging,
;;; tracing, etc.) traps, it makes sense to be able to leverage that
;;; same code for certain events that are trap-like, but not actually
;;; traps in the sense of the calls made by libguile's evaluator.

;;; The main example of this is when an error is signalled.  Guile
;;; doesn't yet have a 100% reliable way of hooking into errors, but
;;; in practice most errors go through a lazy-catch whose handler is
;;; lazy-handler-dispatch (defined in ice-9/boot-9.scm), which in turn
;;; calls default-lazy-handler.  So we can present most errors as
;;; pseudo-traps by modifying default-lazy-handler.

(define default-default-lazy-handler default-lazy-handler)

(define (throw->trap-context key args . stack-args)
  (let ((ctx (make <trap-context>
	       #:type #:error
	       #:continuation #f
	       #:return-value (cons key args))))
    (slot-set! ctx 'stack
	       (let ((caller-stack (and (= (length stack-args) 1)
					(car stack-args))))
		 (if (stack? caller-stack)
		     caller-stack
		     (apply make-stack #t stack-args))))
    ctx))

(define (on-lazy-handler-dispatch behaviour . ignored-keys)
  (set! default-lazy-handler
	(if behaviour
	    (lambda (key . args)
	      (or (memq key ignored-keys)
		  (behaviour (throw->trap-context key
						  args
						  lazy-handler-dispatch)))
	      (apply default-default-lazy-handler key args))
	    default-default-lazy-handler)))

;;; {Trap Classes}

;;; Class: <trap>
;;;
;;; <trap> is the base class for traps.  Any actual trap should be an
;;; instance of a class derived from <trap>, not of <trap> itself,
;;; because there is no base class method for the install-trap,
;;; trap-runnable? and uninstall-trap GFs.
(define-class <trap> ()
  ;; "number" slot: the number of this trap (assigned automatically).
  (number)
  ;; "installed" slot: whether this trap is installed.
  (installed #:init-value #f)
  ;; "condition" slot: if non-#f, this is a thunk which is called when
  ;; the trap fires, to determine whether trap processing should
  ;; proceed any further.
  (condition #:init-value #f #:init-keyword #:condition)
  ;; "skip-count" slot: a count of valid (after "condition"
  ;; processing) firings of this trap to skip.
  (skip-count #:init-value 0 #:init-keyword #:skip-count)
  ;; "single-shot" slot: if non-#f, this trap is removed after it has
  ;; successfully fired (after "condition" and "skip-count"
  ;; processing) for the first time.
  (single-shot #:init-value #f #:init-keyword #:single-shot)
  ;; "behaviour" slot: procedure or list of procedures to call
  ;; (passing the trap context as parameter) if we finally decide
  ;; (after "condition" and "skip-count" processing) to run this
  ;; trap's behaviour.
  (behaviour #:init-value '() #:init-keyword #:behaviour)
  ;; "repeat-identical-behaviour" slot: normally, if multiple <trap>
  ;; objects are triggered by the same low level trap, and they
  ;; request the same behaviour, it's only useful to do that behaviour
  ;; once (per low level trap); so by default multiple requests for
  ;; the same behaviour are coalesced.  If this slot is non-#f, the
  ;; contents of the "behaviour" slot are uniquified so that they
  ;; avoid being coalesced in this way.
  (repeat-identical-behaviour #:init-value #f
			      #:init-keyword #:repeat-identical-behaviour)
  ;; "observer" slot: this is a procedure that is called with one
  ;; EVENT argument when the trap status changes in certain
  ;; interesting ways, currently the following.  (1) When the trap is
  ;; uninstalled because of the target becoming inaccessible; EVENT in
  ;; this case is 'target-gone.
  (observer #:init-value #f #:init-keyword #:observer))

(define last-assigned-trap-number 0)
(define all-traps (make-weak-value-hash-table 7))

(define-method (initialize (trap <trap>) initargs)
  (next-method)
  ;; Assign a trap number, and store in the hash of all traps.
  (set! last-assigned-trap-number (+ last-assigned-trap-number 1))
  (slot-set! trap 'number last-assigned-trap-number)
  (hash-set! all-traps last-assigned-trap-number trap)
  ;; Listify the behaviour slot, if not a list already.
  (let ((behaviour (slot-ref trap 'behaviour)))
    (if (procedure? behaviour)
	(slot-set! trap 'behaviour (list behaviour)))))

(define-generic install-trap)		; provided mostly by subclasses
(define-generic uninstall-trap)		; provided mostly by subclasses
(define-generic trap->behaviour)	; provided by <trap>
(define-generic trap-runnable?)		; provided by subclasses

(define-method (install-trap (trap <trap>))
  (if (slot-ref trap 'installed)
      (error "Trap is already installed"))
  (slot-set! trap 'installed #t))

(define-method (uninstall-trap (trap <trap>))
  (or (slot-ref trap 'installed)
      (error "Trap is not installed"))
  (slot-set! trap 'installed #f))

;;; uniquify-behaviour
;;;
;;; Uniquify BEHAVIOUR by wrapping it in a new lambda.
(define (uniquify-behaviour behaviour)
  (lambda (trap-context)
    (behaviour trap-context)))

;;; trap->behaviour
;;;
;;; If TRAP is runnable, given TRAP-CONTEXT, return a list of
;;; behaviour procs to call with TRAP-CONTEXT as a parameter.
;;; Otherwise return the empty list.
(define-method (trap->behaviour (trap <trap>) (trap-context <trap-context>))
  (if (and
       ;; Check that the trap is runnable.  Runnability is implemented
       ;; by the subclass and allows us to check, for example, that
       ;; the procedure being applied in an apply-frame trap matches
       ;; this trap's procedure.
       (trap-runnable? trap trap-context)
       ;; Check the additional condition, if specified.
       (let ((condition (slot-ref trap 'condition)))
	 (or (not condition)
	     ((condition))))
       ;; Check for a skip count.
       (let ((skip-count (slot-ref trap 'skip-count)))
	 (if (zero? skip-count)
	     #t
	     (begin
	       (slot-set! trap 'skip-count (- skip-count 1))
	       #f))))
      ;; All checks passed, so we will return the contents of this
      ;; trap's behaviour slot.
      (begin
	;; First, though, remove this trap if its single-shot slot
	;; indicates that it should fire only once.
	(if (slot-ref trap 'single-shot)
	    (uninstall-trap trap))
	;; Add this trap object to the context's list of traps which
	;; fired here.
	(slot-set! trap-context 'fired-traps
		   (cons trap (tc:fired-traps trap-context)))
	;; Return trap behaviour, uniquified if necessary.
	(if (slot-ref trap 'repeat-identical-behaviour)
	    (map uniquify-behaviour (slot-ref trap 'behaviour))
	    (slot-ref trap 'behaviour)))
      '()))

;;; Class: <procedure-trap>
;;;
;;; An installed instance of <procedure-trap> triggers on invocation
;;; of a specific procedure.
(define-class <procedure-trap> (<trap>)
  ;; "procedure" slot: the procedure to trap on.  This is implemented
  ;; virtually, using the following weak vector slot, so as to avoid
  ;; this trap preventing the GC of the target procedure.
  (procedure #:init-keyword #:procedure
	     #:allocation #:virtual
	     #:slot-ref
	     (lambda (trap)
	       (vector-ref (slot-ref trap 'procedure-wv) 0))
	     #:slot-set!
	     (lambda (trap proc)
	       (if (slot-bound? trap 'procedure-wv)
		   (vector-set! (slot-ref trap 'procedure-wv) 0 proc)
		   (slot-set! trap 'procedure-wv (weak-vector proc)))))
  (procedure-wv))

;; Customization of the initialize method: set up to handle what
;; should happen when the procedure is GC'd.
(define-method (initialize (trap <procedure-trap>) initargs)
  (next-method)
  (let* ((proc (slot-ref trap 'procedure))
	 (existing-traps (volatile-target-traps proc)))
    ;; If this is the target's first trap, give the target procedure
    ;; to the volatile-target-guardian, so we can find out if it
    ;; becomes inaccessible.
    (or existing-traps (volatile-target-guardian proc))
    ;; Add this trap to the target procedure's list of traps.
    (set! (volatile-target-traps proc)
	  (cons trap (or existing-traps '())))))

(define procedure-trace-count (make-object-property))

(define-method (install-trap (trap <procedure-trap>))
  (next-method)
  (let* ((proc (slot-ref trap 'procedure))
         (trace-count (or (procedure-trace-count proc) 0)))
    (set-procedure-property! proc 'trace #t)
    (set! (procedure-trace-count proc) (+ trace-count 1)))
  (install-trace-trap trap))

(define-method (uninstall-trap (trap <procedure-trap>))
  (next-method)
  (let* ((proc (slot-ref trap 'procedure))
         (trace-count (or (procedure-trace-count proc) 0)))
    (if (= trace-count 1)
        (set-procedure-property! proc 'trace #f))
    (set! (procedure-trace-count proc) (- trace-count 1)))
  (uninstall-trace-trap trap))

(define-method (trap-runnable? (trap <procedure-trap>)
			       (trap-context <trap-context>))
  (eq? (slot-ref trap 'procedure)
       (frame-procedure (tc:frame trap-context))))

;;; Class: <exit-trap>
;;;
;;; An installed instance of <exit-trap> triggers on stack frame exit
;;; past a specified stack depth.
(define-class <exit-trap> (<trap>)
  ;; "depth" slot: the reference depth for the trap.
  (depth #:init-keyword #:depth))

(define-method (install-trap (trap <exit-trap>))
  (next-method)
  (install-exit-frame-trap trap))

(define-method (uninstall-trap (trap <exit-trap>))
  (next-method)
  (uninstall-exit-frame-trap trap))

(define-method (trap-runnable? (trap <exit-trap>)
			       (trap-context <trap-context>))
  (<= (tc:exit-depth trap-context)
      (slot-ref trap 'depth)))

;;; Class: <entry-trap>
;;;
;;; An installed instance of <entry-trap> triggers on any frame entry.
(define-class <entry-trap> (<trap>))

(define-method (install-trap (trap <entry-trap>))
  (next-method)
  (install-enter-frame-trap trap))

(define-method (uninstall-trap (trap <entry-trap>))
  (next-method)
  (uninstall-enter-frame-trap trap))

(define-method (trap-runnable? (trap <entry-trap>)
			       (trap-context <trap-context>))
  #t)

;;; Class: <apply-trap>
;;;
;;; An installed instance of <apply-trap> triggers on any procedure
;;; application.
(define-class <apply-trap> (<trap>))

(define-method (install-trap (trap <apply-trap>))
  (next-method)
  (install-apply-frame-trap trap))

(define-method (uninstall-trap (trap <apply-trap>))
  (next-method)
  (uninstall-apply-frame-trap trap))

(define-method (trap-runnable? (trap <apply-trap>)
			       (trap-context <trap-context>))
  #t)

;;; Class: <step-trap>
;;;
;;; An installed instance of <step-trap> triggers on the next frame
;;; entry, exit or application, optionally with source location inside
;;; a specified file.
(define-class <step-trap> (<exit-trap>)
  ;; "file-name" slot: if non-#f, indicates that this trap should
  ;; trigger only for steps in source code from the specified file.
  (file-name #:init-value #f #:init-keyword #:file-name)
  ;; "exit-depth" slot: when non-#f, indicates that the next step may
  ;; be a frame exit past this depth; otherwise, indicates that the
  ;; next step must be an application or a frame entry.
  (exit-depth #:init-value #f #:init-keyword #:exit-depth))

(define-method (initialize (trap <step-trap>) initargs)
  (next-method)
  (slot-set! trap 'depth (slot-ref trap 'exit-depth)))

(define-method (install-trap (trap <step-trap>))
  (next-method)
  (install-enter-frame-trap trap)
  (install-apply-frame-trap trap))

(define-method (uninstall-trap (trap <step-trap>))
  (next-method)
  (uninstall-enter-frame-trap trap)
  (uninstall-apply-frame-trap trap))

(define-method (trap-runnable? (trap <step-trap>)
			       (trap-context <trap-context>))
  (if (eq? (tc:type trap-context) #:return)
      ;; We're in the context of an exit-frame trap.  Trap should only
      ;; be run if exit-depth is set and this exit-frame has returned
      ;; past the set depth.
      (and (slot-ref trap 'exit-depth)
	   (next-method)
	   ;; OK to run the trap here, but we should first reset the
	   ;; exit-depth slot to indicate that the step after this one
	   ;; must be an application or frame entry.
	   (begin
	     (slot-set! trap 'exit-depth #f)
	     #t))
      ;; We're in the context of an application or frame entry trap.
      ;; Check whether trap is limited to a specified file.
      (let ((file-name (slot-ref trap 'file-name)))
	(and (or (not file-name)
		 (equal? (frame-file-name (tc:frame trap-context)) file-name))
	     ;; Trap should run here, but we should also set exit-depth to
	     ;; the current stack length, so that - if we don't stop at any
	     ;; other steps first - the next step shows the return value of
	     ;; the current application or evaluation.
	     (begin
	       (slot-set! trap 'exit-depth (tc:depth trap-context))
	       (slot-set! trap 'depth (tc:depth trap-context))
	       #t)))))

(define (frame->source-position frame)
  (let ((source (if (frame-procedure? frame)
		    (or (frame-source frame)
			(let ((proc (frame-procedure frame)))
			  (and proc
			       (procedure? proc)
			       (procedure-source proc))))
		    (frame-source frame))))
    (and source
	 (string? (source-property source 'filename))
	 (list (source-property source 'filename)
	       (source-property source 'line)
	       (source-property source 'column)))))

(define (frame-file-name frame)
  (cond ((frame->source-position frame) => car)
	(else #f)))

;;; Class: <source-trap>
;;;
;;; An installed instance of <source-trap> triggers upon evaluation of
;;; a specified source expression.
(define-class <source-trap> (<trap>)
  ;; "expression" slot: the expression to trap on.  This is
  ;; implemented virtually, using the following weak vector slot, so
  ;; as to avoid this trap preventing the GC of the target source
  ;; code.
  (expression #:init-keyword #:expression
	      #:allocation #:virtual
	      #:slot-ref
	      (lambda (trap)
		(vector-ref (slot-ref trap 'expression-wv) 0))
	      #:slot-set!
	      (lambda (trap expr)
		(if (slot-bound? trap 'expression-wv)
		    (vector-set! (slot-ref trap 'expression-wv) 0 expr)
		    (slot-set! trap 'expression-wv (weak-vector expr)))))
  (expression-wv)
  ;; source property slots - for internal use only
  (filename)
  (line)
  (column))

;; Customization of the initialize method: get and save the
;; expression's source properties, or signal an error if it doesn't
;; have the necessary properties.
(define-method (initialize (trap <source-trap>) initargs)
  (next-method)
  (let* ((expr (slot-ref trap 'expression))
	 (filename (source-property expr 'filename))
         (line (source-property expr 'line))
         (column (source-property expr 'column))
	 (existing-traps (volatile-target-traps expr)))
    (or (and filename line column)
        (error "Specified source does not have the necessary properties"
               filename line column))
    (slot-set! trap 'filename filename)
    (slot-set! trap 'line line)
    (slot-set! trap 'column column)
    ;; If this is the target's first trap, give the target expression
    ;; to the volatile-target-guardian, so we can find out if it
    ;; becomes inaccessible.
    (or existing-traps (volatile-target-guardian expr))
    ;; Add this trap to the target expression's list of traps.
    (set! (volatile-target-traps expr)
	  (cons trap (or existing-traps '())))))

;; Just in case more than one trap is installed on the same source
;; expression ... so that we can still get the setting and resetting
;; of the 'breakpoint source property correct.
(define source-breakpoint-count (make-object-property))

(define-method (install-trap (trap <source-trap>))
  (next-method)
  (let* ((expr (slot-ref trap 'expression))
         (breakpoint-count (or (source-breakpoint-count expr) 0)))
    (set-source-property! expr 'breakpoint #t)
    (set! (source-breakpoint-count expr) (+ breakpoint-count 1)))
  (install-breakpoint-trap trap))

(define-method (uninstall-trap (trap <source-trap>))
  (next-method)
  (let* ((expr (slot-ref trap 'expression))
         (breakpoint-count (or (source-breakpoint-count expr) 0)))
    (if (= breakpoint-count 1)
        (set-source-property! expr 'breakpoint #f))
    (set! (source-breakpoint-count expr) (- breakpoint-count 1)))
  (uninstall-breakpoint-trap trap))

(define-method (trap-runnable? (trap <source-trap>)
			       (trap-context <trap-context>))
  (or (eq? (slot-ref trap 'expression)
           (tc:expression trap-context))
      (let ((trap-location (frame->source-position (tc:frame trap-context))))
        (and trap-location
             (string=? (car trap-location) (slot-ref trap 'filename))
             (= (cadr trap-location) (slot-ref trap 'line))
             (= (caddr trap-location) (slot-ref trap 'column))))))

;; (trap-here EXPRESSION . OPTIONS)
(define trap-here
  (procedure->memoizing-macro
   (lambda (expr env)
     (let ((trap (apply make
                        <source-trap>
                        #:expression expr
                        (local-eval `(list ,@(cddr expr))
                                    env))))
       (install-trap trap)
       (set-car! expr 'begin)
       (set-cdr! (cdr expr) '())
       expr))))

;;; Class: <location-trap>
;;;
;;; An installed instance of <location-trap> triggers on entry to a
;;; frame with a more-or-less precisely specified source location.
(define-class <location-trap> (<trap>)
  ;; "file-regexp" slot: regexp matching the name(s) of the file(s) to
  ;; trap in.
  (file-regexp #:init-keyword #:file-regexp)
  ;; "line" and "column" slots: position to trap at (0-based).
  (line #:init-value #f #:init-keyword #:line)
  (column #:init-value #f #:init-keyword #:column)
  ;; "compiled-regexp" slot - self explanatory, internal use only
  (compiled-regexp))

(define-method (initialize (trap <location-trap>) initargs)
  (next-method)
  (slot-set! trap 'compiled-regexp
             (make-regexp (slot-ref trap 'file-regexp))))

(define-method (install-trap (trap <location-trap>))
  (next-method)
  (install-enter-frame-trap trap))

(define-method (uninstall-trap (trap <location-trap>))
  (next-method)
  (uninstall-enter-frame-trap trap))

(define-method (trap-runnable? (trap <location-trap>)
			       (trap-context <trap-context>))
  (and-let* ((trap-location (frame->source-position (tc:frame trap-context)))
	     (tcline (cadr trap-location))
	     (tccolumn (caddr trap-location)))
    (and (= tcline (slot-ref trap 'line))
	 (= tccolumn (slot-ref trap 'column))
         (regexp-exec (slot-ref trap 'compiled-regexp)
		      (car trap-location) 0))))

;;; {Misc Trap Utilities}

(define (get-trap number)
  (hash-ref all-traps number))

(define (list-traps)
  (for-each describe
	    (map cdr (sort (hash-fold acons '() all-traps)
			   (lambda (x y) (< (car x) (car y)))))))

;;; {Volatile Traps}
;;;
;;; Some traps are associated with Scheme objects that are likely to
;;; be GC'd, such as procedures and read expressions.  When those
;;; objects are GC'd, we want to allow their traps to evaporate as
;;; well, or at least not to prevent them from doing so because they
;;; are (now pointlessly) included on the various installed trap
;;; lists.

;; An object property that maps each volatile target to the list of
;; traps that are installed on it.
(define volatile-target-traps (make-object-property))

;; A guardian that tells us when a volatile target is no longer
;; accessible.
(define volatile-target-guardian (make-guardian))

;; An after GC hook that checks for newly inaccessible targets.
(add-hook! after-gc-hook
	   (lambda ()
	     (trc 'after-gc-hook)
	     (let loop ((target (volatile-target-guardian)))
	       (if target
                   ;; We have a target which is now inaccessible.  Get
                   ;; the list of traps installed on it.
		   (begin
		     (trc 'after-gc-hook "got target")
		     ;; Uninstall all the traps that are installed on
		     ;; this target.
		     (for-each (lambda (trap)
				 (trc 'after-gc-hook "got trap")
				 ;; If the trap is still installed,
				 ;; uninstall it.
				 (if (slot-ref trap 'installed)
				     (uninstall-trap trap))
				 ;; If the trap has an observer, tell
				 ;; it that the target has gone.
				 (cond ((slot-ref trap 'observer)
					=>
					(lambda (proc)
					  (trc 'after-gc-hook "call obs")
					  (proc 'target-gone)))))
			       (or (volatile-target-traps target) '()))
                     ;; Check for any more inaccessible targets.
		     (loop (volatile-target-guardian)))))))

(define (without-traps thunk)
  (with-traps (lambda ()
		(trap-disable 'traps)
		(thunk))))

(define guile-trap-features
  ;; Helper procedure, to test whether a specific possible Guile
  ;; feature is supported.
  (let ((supported?
         (lambda (test-feature)
           (case test-feature
             ((tweaking)
              ;; Tweaking is supported if the description of the cheap
              ;; traps option includes the word "obsolete", or if the
              ;; option isn't there any more.
              (and (string>=? (version) "1.7")
                   (let ((cheap-opt-desc
                          (assq 'cheap (debug-options-interface 'help))))
                     (or (not cheap-opt-desc)
                         (string-match "obsolete" (caddr cheap-opt-desc))))))
             (else
              (error "Unexpected feature name:" test-feature))))))
    ;; Compile the list of actually supported features from all
    ;; possible features.
    (let loop ((possible-features '(tweaking))
               (actual-features '()))
      (if (null? possible-features)
          (reverse! actual-features)
          (let ((test-feature (car possible-features)))
            (loop (cdr possible-features)
                  (if (supported? test-feature)
                      (cons test-feature actual-features)
                      actual-features)))))))

;; Make sure that traps are enabled.
(trap-enable 'traps)

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


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

;;; 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 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 debugging trc) ends here.

license: unknown


code:
;;;; Copyright (C) 2003, 2005, 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
;;;;

;;;; Deprecated definitions.

(define substring-move-left! substring-move!)
(define substring-move-right! substring-move!)

;; This method of dynamically linking Guile Extensions is deprecated.
;; Use `load-extension' explicitly from Scheme code instead.

(define (split-c-module-name str)
  (let loop ((rev '())
	     (start 0)
	     (pos 0)
	     (end (string-length str)))
    (cond
     ((= pos end)
      (reverse (cons (string->symbol (substring str start pos)) rev)))
     ((eq? (string-ref str pos) #\space)
      (loop (cons (string->symbol (substring str start pos)) rev)
	    (+ pos 1)
	    (+ pos 1)
	    end))
     (else
      (loop rev start (+ pos 1) end)))))

(define (convert-c-registered-modules dynobj)
  (let ((res (map (lambda (c)
		    (list (split-c-module-name (car c)) (cdr c) dynobj))
		  (c-registered-modules))))
    (c-clear-registered-modules)
    res))

(define registered-modules '())

(define (register-modules dynobj)
  (set! registered-modules
	(append! (convert-c-registered-modules dynobj)
		 registered-modules)))

(define (warn-autoload-deprecation modname)
  (issue-deprecation-warning
   "Autoloading of compiled code modules is deprecated."
   "Write a Scheme file instead that uses `load-extension'.")
  (issue-deprecation-warning
   (simple-format #f "(You just autoloaded module ~S.)" modname)))

(define (init-dynamic-module modname)
  ;; Register any linked modules which have been registered on the C level
  (register-modules #f)
  (or-map (lambda (modinfo)
	    (if (equal? (car modinfo) modname)
		(begin
		  (warn-autoload-deprecation modname)
		  (set! registered-modules (delq! modinfo registered-modules))
		  (let ((mod (resolve-module modname #f)))
		    (save-module-excursion
		     (lambda ()
		       (set-current-module mod)
		       (set-module-public-interface! mod mod)
		       (dynamic-call (cadr modinfo) (caddr modinfo))
		       ))
		    #t))
		#f))
	  registered-modules))

(define (dynamic-maybe-call name dynobj)
  (catch #t				; could use false-if-exception here
	 (lambda ()
	   (dynamic-call name dynobj))
	 (lambda args
	   #f)))

(define (dynamic-maybe-link filename)
  (catch #t				; could use false-if-exception here
	 (lambda ()
	   (dynamic-link filename))
	 (lambda args
	   #f)))

(define (find-and-link-dynamic-module module-name)
  (define (make-init-name mod-name)
    (string-append "scm_init"
		   (list->string (map (lambda (c)
					(if (or (char-alphabetic? c)
						(char-numeric? c))
					    c
					    #\_))
				      (string->list mod-name)))
		   "_module"))

  ;; Put the subdirectory for this module in the car of SUBDIR-AND-LIBNAME,
  ;; and the `libname' (the name of the module prepended by `lib') in the cdr
  ;; field.  For example, if MODULE-NAME is the list (inet tcp-ip udp), then
  ;; SUBDIR-AND-LIBNAME will be the pair ("inet/tcp-ip" . "libudp").
  (let ((subdir-and-libname
	 (let loop ((dirs "")
		    (syms module-name))
	   (if (null? (cdr syms))
	       (cons dirs (string-append "lib" (symbol->string (car syms))))
	       (loop (string-append dirs (symbol->string (car syms)) "/")
		     (cdr syms)))))
	(init (make-init-name (apply string-append
				     (map (lambda (s)
					    (string-append "_"
							   (symbol->string s)))
					  module-name)))))
    (let ((subdir (car subdir-and-libname))
	  (libname (cdr subdir-and-libname)))

      ;; Now look in each dir in %LOAD-PATH for `subdir/libfoo.la'.  If that
      ;; file exists, fetch the dlname from that file and attempt to link
      ;; against it.  If `subdir/libfoo.la' does not exist, or does not seem
      ;; to name any shared library, look for `subdir/libfoo.so' instead and
      ;; link against that.
      (let check-dirs ((dir-list %load-path))
	(if (null? dir-list)
	    #f
	    (let* ((dir (in-vicinity (car dir-list) subdir))
		   (sharlib-full
		    (or (try-using-libtool-name dir libname)
			(try-using-sharlib-name dir libname))))
	      (if (and sharlib-full (file-exists? sharlib-full))
		  (link-dynamic-module sharlib-full init)
		  (check-dirs (cdr dir-list)))))))))

(define (try-using-libtool-name libdir libname)
  (let ((libtool-filename (in-vicinity libdir
				       (string-append libname ".la"))))
    (and (file-exists? libtool-filename)
	 libtool-filename)))

(define (try-using-sharlib-name libdir libname)
  (in-vicinity libdir (string-append libname ".so")))

(define (link-dynamic-module filename initname)
  ;; Register any linked modules which have been registered on the C level
  (register-modules #f)
  (let ((dynobj (dynamic-link filename)))
    (dynamic-call initname dynobj)
    (register-modules dynobj)))

(define (try-module-linked module-name)
  (init-dynamic-module module-name))

(define (try-module-dynamic-link module-name)
  (and (find-and-link-dynamic-module module-name)
       (init-dynamic-module module-name)))

(define (list* . args)
  (issue-deprecation-warning "'list*' is deprecated.  Use 'cons*' instead.")
  (apply cons* args))

;; The strange prototype system for uniform arrays has been
;; deprecated.

(define uniform-vector-fill! array-fill!)

(define make-uniform-vector dimensions->uniform-array)

(define (make-uniform-array prot . bounds)
  (dimensions->uniform-array bounds prot))

(define (list->uniform-vector prot lst)
  (list->uniform-array 1 prot lst))


code:
;;;; 	Copyright (C) 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
;;;;

;;; Commentary:

;; * This module exports:
;;
;; file-commentary      -- a procedure that returns a file's "commentary"
;;
;; documentation-files  -- a search-list of files using the Guile
;;                         Documentation Format Version 2.
;;
;; search-documentation-files -- a procedure that takes NAME (a symbol)
;;                               and searches `documentation-files' for
;;                               associated documentation.  optional
;;                               arg FILES is a list of filenames to use
;;                               instead of `documentation-files'.
;;
;; object-documentation -- a procedure that returns its arg's docstring
;;
;; * Guile Documentation Format
;;
;; Here is the complete and authoritative documentation for the Guile
;; Documentation Format Version 2:
;;
;; HEADER
;; ^LPROC1
;; DOCUMENTATION1
;;
;; ^LPROC2
;; DOCUMENTATION2
;;
;; ^L...
;;
;; The HEADER is completely ignored.  The "^L" are formfeeds.  PROC1, PROC2
;; and so on are symbols that name the element documented.  DOCUMENTATION1,
;; DOCUMENTATION2 and so on are the related documentation, w/o any further
;; formatting.  Note that there are two newlines before the next formfeed;
;; these are discarded when the documentation is read in.
;;
;; (Version 1, corresponding to guile-1.4 and prior, is documented as being
;; not documented anywhere except by this embarrassingly circular comment.)
;;
;; * File Commentary
;;
;; A file's commentary is the body of text found between comments
;;     ;;; Commentary:
;; and
;;     ;;; Code:
;; both of which must be at the beginning of the line.  In the result string,
;; semicolons at the beginning of each line are discarded.
;;
;; You can specify to `file-commentary' alternate begin and end strings, and
;; scrub procedure.  Use #t to get default values.  For example:
;;
;; (file-commentary "documentation.scm")
;; You should see this text!
;;
;; (file-commentary "documentation.scm" "^;;; Code:" "ends here$")
;; You should see the rest of this file.
;;
;; (file-commentary "documentation.scm" #t #t string-upcase)
;; You should see this text very loudly (note semicolons untouched).

;;; Code:

(define-module (ice-9 documentation)
  :use-module (ice-9 rdelim)
  :export (file-commentary
           documentation-files search-documentation-files
           object-documentation)
  :autoload (ice-9 regex) (match:suffix)
  :no-backtrace)

;;
;; commentary extraction
;;

(define (file-commentary filename . cust) ; (IN-LINE-RE AFTER-LINE-RE SCRUB)

  ;; These are constants but are not at the top level because the repl in
  ;; boot-9.scm loads session.scm which in turn loads this file, and we want
  ;; that to work even even when regexps are not available (ie. make-regexp
  ;; doesn't exist), as for instance is the case on mingw.
  ;;
  (define default-in-line-re (make-regexp "^;;; Commentary:"))
  (define default-after-line-re (make-regexp "^;;; Code:"))
  (define default-scrub (let ((dirt (make-regexp "^;+")))
			  (lambda (line)
			    (let ((m (regexp-exec dirt line)))
			      (if m (match:suffix m) line)))))

  ;; fixme: might be cleaner to use optargs here...
  (let ((in-line-re (if (> 1 (length cust))
                        default-in-line-re
                        (let ((v (car cust)))
                          (cond ((regexp? v) v)
                                ((string? v) (make-regexp v))
                                (else default-in-line-re)))))
        (after-line-re (if (> 2 (length cust))
                           default-after-line-re
                           (let ((v (cadr cust)))
                             (cond ((regexp? v) v)
                                   ((string? v) (make-regexp v))
                                   (else default-after-line-re)))))
        (scrub (if (> 3 (length cust))
                   default-scrub
                   (let ((v (caddr cust)))
                     (cond ((procedure? v) v)
                           (else default-scrub))))))
    (call-with-input-file filename
      (lambda (port)
	(let loop ((line (read-delimited "\n" port))
		   (doc "")
		   (parse-state 'before))
	  (if (or (eof-object? line) (eq? 'after parse-state))
	      doc
	      (let ((new-state
		     (cond ((regexp-exec in-line-re line) 'in)
			   ((regexp-exec after-line-re line) 'after)
			   (else parse-state))))
		(if (eq? 'after new-state)
		    doc
		    (loop (read-delimited "\n" port)
			  (if (and (eq? 'in new-state) (eq? 'in parse-state))
			      (string-append doc (scrub line) "\n")
			      doc)
			  new-state)))))))))

;;
;; documentation-files is the list of places to look for documentation
;;
(define documentation-files
  (map (lambda (vicinity)
	 (in-vicinity (vicinity) "guile-procedures.txt"))
       (list %library-dir
	     %package-data-dir
	     %site-dir
	     (lambda () "."))))

(define entry-delimiter "\f")

(define (find-documentation-in-file name file)
  (and (file-exists? file)
       (call-with-input-file file
	 (lambda (port)
	   (let ((name (symbol->string name)))
	     (let ((len (string-length name)))
	       (read-delimited entry-delimiter port) ;skip to first entry
	       (let loop ((entry (read-delimited entry-delimiter port)))
		 (cond ((eof-object? entry) #f)
		       ;; match?
		       ((and ;; large enough?
		         (>= (string-length entry) len)
			 ;; matching name?
			 (string=? (substring entry 0 len) name)
			 ;; terminated?
			 (memq (string-ref entry len) '(#\newline)))
			;; cut away name tag and extra surrounding newlines
			(substring entry (+ len 2) (- (string-length entry) 2)))
		       (else (loop (read-delimited entry-delimiter port)))))))))))

(define (search-documentation-files name . files)
  (or-map (lambda (file)
	    (find-documentation-in-file name file))
          (cond ((null? files) documentation-files)
                (else files))))

;; helper until the procedure documentation property is cleaned up
(define (proc-doc proc)
  (or (procedure-documentation proc)
      (procedure-property proc 'documentation)))

(define (object-documentation object)
  "Return the docstring for OBJECT.
OBJECT can be a procedure, macro or any object that has its
`documentation' property set."
  (or (and (procedure? object)
	   (proc-doc object))
      (and (defmacro? object)
	   (proc-doc (defmacro-transformer object)))
      (and (macro? object)
	   (let ((transformer (macro-transformer object)))
	     (and transformer
		  (proc-doc transformer))))
      (object-property object 'documentation)
      (and (procedure? object)
	   (not (closure? object))
	   (procedure-name object)
	   (let ((docstring (search-documentation-files
                             (procedure-name object))))
	     (if docstring
		 (set-procedure-property! object 'documentation docstring))
	     docstring))))

;;; documentation.scm ends here


code:
;;;; 	Copyright (C) 1996, 1997, 1998, 1999, 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
;;;;
;;;; The author can be reached at djurfeldt@nada.kth.se
;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
;;;; (I didn't write this!)
;;;;

;;; *********************************************************************
;;; * This is the Guile side of the Emacs interface                     *
;;; * Experimental hACK---the real version will be coming soon (almost) *
;;; *********************************************************************

;;; {Session support for Emacs}
;;;

(define-module (ice-9 emacs)
  :use-module (ice-9 debug)
  :use-module (ice-9 threads)
  :use-module (ice-9 session)
  :no-backtrace)

(define emacs-escape-character #\sub)

(define emacs-output-port (current-output-port))

(define (make-emacs-command char)
  (let ((cmd (list->string (list emacs-escape-character char))))
    (lambda ()
      (display cmd emacs-output-port))))

(define enter-input-wait  (make-emacs-command #\s))
(define exit-input-wait   (make-emacs-command #\f))
(define enter-read-character #\r)
(define sending-error	  (make-emacs-command #\F))
(define sending-backtrace (make-emacs-command #\B))
(define sending-result    (make-emacs-command #\x))
(define end-of-text	  (make-emacs-command #\.))
(define no-stack	  (make-emacs-command #\S))
(define no-source	  (make-emacs-command #\R))

;; {Error handling}
;;

(add-hook! before-backtrace-hook sending-backtrace)
(add-hook! after-backtrace-hook end-of-text)
(add-hook! before-error-hook sending-error)
(add-hook! after-error-hook end-of-text)

;; {Repl}
;;

(set-current-error-port emacs-output-port)

(add-hook! before-read-hook
	   (lambda ()
	     (enter-input-wait)
	     (force-output emacs-output-port)))

(add-hook! after-read-hook
	   (lambda ()
	     (exit-input-wait)
	     (force-output emacs-output-port)))

;;; {Misc.}

(define (make-emacs-load-port orig-port)
  (letrec ((read-char-fn  (lambda args
			    (let ((c (read-char orig-port)))
			      (if (eq? c #\soh)
				  (throw 'end-of-chunk)
				  c)))))

    (make-soft-port
     (vector #f #f #f
	     read-char-fn
	     (lambda () (close-port orig-port)))
     "r")))

(set-current-input-port (make-emacs-load-port (current-input-port)))

(define (result-to-emacs exp)
  (sending-result)
  (write exp emacs-output-port)
  (end-of-text)
  (force-output emacs-output-port))

(define load-acknowledge (make-emacs-command #\l))

(define load-port (current-input-port))

(define (flush-line port)
  (let loop ((c (read-char port)))
    (if (not (eq? c #\nl))
	(loop (read-char port)))))

(define whitespace-chars (list #\space #\tab #\nl #\np))

(define (flush-whitespace port)
  (catch 'end-of-chunk
	 (lambda ()
	   (let loop ((c (read-char port)))
	     (cond ((eq? c the-eof-object)
		    (error "End of file while receiving Emacs data"))
		   ((memq c whitespace-chars) (loop (read-char port)))
		   ((eq? c #\;) (flush-line port) (loop (read-char port)))
		   (else (unread-char c port))))
	   #f)
	 (lambda args
	   (read-char port) ; Read final newline
	   #t)))

(define (emacs-load filename linum colnum module interactivep)
  (define (read-and-eval! port)
    (let ((x (read port)))
      (if (eof-object? x)
	  (throw 'end-of-file)
	  (primitive-eval x))))
  (set-port-filename! %%load-port filename)
  (set-port-line! %%load-port linum)
  (set-port-column! %%load-port colnum)
  (lazy-catch #t
	      (lambda ()
		(let loop ((endp (flush-whitespace %%load-port)))
		  (if (not endp)
		      (begin
			(save-module-excursion
			 (lambda ()
			   (if module
			       (set-current-module (resolve-module module #f)))
			   (let ((result
				  (start-stack read-and-eval!
					       (read-and-eval! %%load-port))))
			     (if interactivep
				 (result-to-emacs result)))))
			(loop (flush-whitespace %%load-port)))
		      (begin
			(load-acknowledge)))
		  (set-port-filename! %%load-port #f)))	;reset port filename
	      (lambda (key . args)
		(set-port-filename! %%load-port #f)
		(cond ((eq? key 'end-of-chunk)
		       (fluid-set! the-last-stack #f)
		       (set! stack-saved? #t)
		       (scm-error 'misc-error
				  #f
				  "Incomplete expression"
				  '()
				  '()))
		      ((eq? key 'exit))
		      (else
		       (save-stack 2)
		       (catch 'end-of-chunk
			      (lambda ()
				(let loop ()
				  (read-char %%load-port)
				  (loop)))
			      (lambda args
				#f))
		       (apply throw key args))))))

(define (emacs-eval-request form)
  (result-to-emacs (eval form (interaction-environment))))

;;*fixme* Not necessary to use flags no-stack and no-source
(define (get-frame-source frame)
  (if (or (not (fluid-ref the-last-stack))
	  (>= frame (stack-length (fluid-ref the-last-stack))))
      (begin
	(no-stack)
	#f)
      (let* ((frame (stack-ref (fluid-ref the-last-stack)
			       (frame-number->index frame)))
	     (source (frame-source frame)))
	(or source
	    (begin (no-source)
		   #f)))))

(define (emacs-select-frame frame)
  (let ((source (get-frame-source frame)))
    (if source
	(let ((fname (source-property source 'filename))
	      (line (source-property source 'line))
	      (column (source-property source 'column)))
	  (if (and fname line column)
	      (list fname line column)
	      (begin (no-source)
		     '())))
	'())))

(define (object->string x . method)
  (with-output-to-string
    (lambda ()
      ((if (null? method)
	   write
	   (car method))
       x))))

(define (format template . rest)
  (let loop ((chars (string->list template))
	     (result '())
	     (rest rest))
    (cond ((null? chars) (list->string (reverse result)))
	  ((char=? (car chars) #\%)
	   (loop (cddr chars)
		 (append (reverse
			  (string->list
			   (case (cadr chars)
			     ((#\S) (object->string (car rest)))
			     ((#\s) (object->string (car rest) display)))))
			 result)
		 (cdr rest)))
	  (else (loop (cdr chars) (cons (car chars) result) rest)))))

(define (error-args->string args)
  (let ((msg (apply format (caddr args) (cadddr args))))
    (if (symbol? (cadr args))
	(string-append (symbol->string (cadr args))
		       ": "
		       msg)
	msg)))

(define (emacs-frame-eval frame form)
  (let ((source (get-frame-source frame)))
    (if source
	(catch #t
	       (lambda ()
		 (list 'result
		       (object->string
			(local-eval (with-input-from-string form read)
				    (memoized-environment source)))))
	       (lambda args
		 (list (car args)
		       (error-args->string args))))
	(begin
	  (no-source)
	  '()))))

(define (emacs-symdoc symbol)
  (if (or (not (module-bound? (current-module) symbol))
	  (not (procedure? (eval symbol (interaction-environment)))))
      'nil
      (procedure-documentation (eval symbol (interaction-environment)))))

;;; A fix to get the emacs interface to work together with the module system.
;;;
(for-each (lambda (name value)
	    (module-define! the-root-module name value))
	  '(%%load-port
	    %%emacs-load
	    %%emacs-eval-request
	    %%emacs-select-frame
	    %%emacs-frame-eval
	    %%emacs-symdoc
	    %%apropos-internal)
	  (list load-port
		emacs-load
		emacs-eval-request
		emacs-select-frame
		emacs-frame-eval
		emacs-symdoc
		apropos-internal))


code:
;;;; 	Copyright (C) 1996, 1998, 1999, 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:

;; This module is documented in the Guile Reference Manual.
;; Briefly, these are exported:
;;  procedures: expect-select, expect-regexec
;;   variables: expect-port, expect-timeout, expect-timeout-proc,
;;              expect-eof-proc, expect-char-proc,
;;              expect-strings-compile-flags, expect-strings-exec-flags,
;;      macros: expect, expect-strings

;;; Code:

(define-module (ice-9 expect)
  :use-module (ice-9 regex)
  :export-syntax (expect expect-strings)
  :export (expect-port expect-timeout expect-timeout-proc
	   expect-eof-proc expect-char-proc expect-strings-compile-flags
	   expect-strings-exec-flags expect-select expect-regexec))

;;; Expect: a macro for selecting actions based on what it reads from a port.
;;; The idea is from Don Libes' expect based on Tcl.
;;; This version by Gary Houston incorporating ideas from Aubrey Jaffer.

(define expect-port #f)
(define expect-timeout #f)
(define expect-timeout-proc #f)
(define expect-eof-proc #f)
(define expect-char-proc #f)

;;; expect: each test is a procedure which is applied to the accumulating
;;; string.
(defmacro expect clauses
  (let ((s (gensym))
	(c (gensym))
	(port (gensym))
	(timeout (gensym)))
    `(let ((,s "")
	   (,port (or expect-port (current-input-port)))
	   ;; when timeout occurs, in floating point seconds.
	   (,timeout (if expect-timeout
			 (let* ((secs-usecs (gettimeofday)))
			   (+ (car secs-usecs)
			      expect-timeout
			      (/ (cdr secs-usecs)
				 1000000))) ; one million.
			 #f)))
       (let next-char ()
	 (if (and expect-timeout
		  (not (expect-select ,port ,timeout)))
	     (if expect-timeout-proc
		 (expect-timeout-proc ,s)
		 #f)
	     (let ((,c (read-char ,port)))
	       (if expect-char-proc
		   (expect-char-proc ,c))
	       (if (not (eof-object? ,c))
		   (set! ,s (string-append ,s (string ,c))))
	       (cond
		;; this expands to clauses where the car invokes the
		;; match proc and the cdr is the return value from expect
		;; if the proc matched.
		,@(let next-expr ((tests (map car clauses))
				  (exprs (map cdr clauses))
				  (body '()))
		    (cond
		     ((null? tests)
		      (reverse body))
		     (else
		      (next-expr
		       (cdr tests)
		       (cdr exprs)
		       (cons
			`((,(car tests) ,s (eof-object? ,c))
			  ,@(cond ((null? (car exprs))
				   '())
				  ((eq? (caar exprs) '=>)
				   (if (not (= (length (car exprs))
					       2))
				       (scm-error 'misc-error
						  "expect"
						  "bad recipient: ~S"
						  (list (car exprs))
						  #f)
				       `((apply ,(cadar exprs)
						(,(car tests) ,s ,port)))))
				  (else
				   (car exprs))))
			body)))))
		;; if none of the clauses matched the current string.
		(else (cond ((eof-object? ,c)
			     (if expect-eof-proc
				 (expect-eof-proc ,s)
				 #f))
			    (else
			     (next-char)))))))))))

(define expect-strings-compile-flags regexp/newline)
(define expect-strings-exec-flags regexp/noteol)

;;; the regexec front-end to expect:
;;; each test must evaluate to a regular expression.
(defmacro expect-strings clauses
  `(let ,@(let next-test ((tests (map car clauses))
			  (exprs (map cdr clauses))
			  (defs '())
			  (body '()))
	    (cond ((null? tests)
		   (list (reverse defs) `(expect ,@(reverse body))))
		  (else
		   (let ((rxname (gensym)))
		     (next-test (cdr tests)
				(cdr exprs)
				(cons `(,rxname (make-regexp
						 ,(car tests)
						 expect-strings-compile-flags))
				      defs)
				(cons `((lambda (s eof?)
					  (expect-regexec ,rxname s eof?))
					,@(car exprs))
				      body))))))))

;;; simplified select: returns #t if input is waiting or #f if timed out or
;;; select was interrupted by a signal.
;;; timeout is an absolute time in floating point seconds.
(define (expect-select port timeout)
  (let* ((secs-usecs (gettimeofday))
	 (relative (- timeout
		      (car secs-usecs)
		      (/ (cdr secs-usecs)
			 1000000))))	; one million.
    (and (> relative 0)
	 (pair? (car (select (list port) '() '()
			     relative))))))

;;; match a string against a regexp, returning a list of strings (required
;;; by the => syntax) or #f.  called once each time a character is added
;;; to s (eof? will be #f), and once when eof is reached (with eof? #t).
(define (expect-regexec rx s eof?)
  ;; if expect-strings-exec-flags contains regexp/noteol,
  ;; remove it for the eof test.
  (let* ((flags (if (and eof?
			 (logand expect-strings-exec-flags regexp/noteol))
		    (logxor expect-strings-exec-flags regexp/noteol)
		    expect-strings-exec-flags))
	 (match (regexp-exec rx s 0 flags)))
    (if match
	(do ((i (- (match:count match) 1) (- i 1))
	     (result '() (cons (match:substring match i) result)))
	    ((< i 0) result))
	#f)))

;;; expect.scm ends here