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

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

(define-module (ice-9 debugging trace)
  #:use-module (ice-9 debugger)
  #:use-module (ice-9 debugger utils)
  #: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))

(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.


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

;;; Copyright (C) 2002, 2004, 2009, 2010 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 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; 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 (ice-9 weak-vector)
  #:use-module (ice-9 scm-style-repl)
  #: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-pre-unwind-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)
  ;; FIXME: see below
  ;; #: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)

;;; 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 catch whose pre-unwind handler is
;;; pre-unwind-handler-dispatch (defined in ice-9/boot-9.scm), which in
;;; turn calls default-pre-unwind-handler. So we can present most errors
;;; as pseudo-traps by modifying default-pre-unwind-handler.

(define default-default-pre-unwind-handler default-pre-unwind-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-pre-unwind-handler-dispatch behaviour . ignored-keys)
  (set! default-pre-unwind-handler
	(if behaviour
	    (lambda (key . args)
	      (or (memq key ignored-keys)
		  (behaviour (throw->trap-context key
						  args
						  default-pre-unwind-handler)))
	      (apply default-default-pre-unwind-handler key args))
	    default-default-pre-unwind-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)
;; FIXME: no longer working due to no mmacros, no local-eval
#;
(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 '(tweaking))

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

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

license: mit


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 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(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.


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

(define-module (ice-9 deprecated)
  #:export (substring-move-left! substring-move-right!
            dynamic-maybe-call dynamic-maybe-link
            try-module-linked try-module-dynamic-link
            list* feature? eval-case unmemoize-expr
            $asinh
            $acosh
            $atanh
            $sqrt
            $abs
            $exp
            $log
            $sin
            $cos
            $tan
            $asin
            $acos
            $atan
            $sinh
            $cosh
            $tanh
            closure?
            %nil
            @bind
            bad-throw
            error-catching-loop
            error-catching-repl
            scm-style-repl
            apply-to-args
            has-suffix?
            scheme-file-suffix
            get-option
            for-next-option
            display-usage-report
            transform-usage-lambda
            collect
            assert-repl-silence
            assert-repl-print-unspecified
            assert-repl-verbosity
            set-repl-prompt!
            set-batch-mode?!
            repl
            pre-unwind-handler-dispatch
            default-pre-unwind-handler
            handle-system-error
            stack-saved?
            the-last-stack
            save-stack
            named-module-use!
            top-repl)

  #:replace (module-ref-submodule module-define-submodule!))

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

(define (feature? sym)
  (issue-deprecation-warning
   "`feature?' is deprecated.  Use `provided?' instead.")
  (provided? sym))

(define-macro (eval-case . clauses)
  (issue-deprecation-warning
   "`eval-case' is deprecated.  Use `eval-when' instead.")
  ;; Practically speaking, eval-case only had load-toplevel and else as
  ;; conditions.
  (cond
   ((assoc-ref clauses '(load-toplevel))
    => (lambda (exps)
         ;; the *unspecified so that non-toplevel definitions will be
         ;; caught
         `(begin *unspecified* . ,exps)))
   ((assoc-ref clauses 'else)
    => (lambda (exps)
         `(begin *unspecified* . ,exps)))
   (else
    `(begin))))

;; The strange prototype system for uniform arrays has been
;; deprecated.
(read-hash-extend
 #\y
 (lambda (c port)
   (issue-deprecation-warning
    "The `#y' bitvector syntax is deprecated.  Use `#*' instead.")
   (let ((x (read port)))
     (cond
      ((list? x)
       (list->bitvector
        (map (lambda (x)
               (cond ((zero? x) #f)
                     ((eqv? x 1) #t)
                     (else (error "invalid #y element" x))))
             x)))
      (else
       (error "#y needs to be followed by a list" x))))))

(define (unmemoize-expr . args)
  (issue-deprecation-warning
   "`unmemoize-expr' is deprecated. Use `unmemoize-expression' instead.")
  (apply unmemoize-expression args))

(define ($asinh z) (asinh z))
(define ($acosh z) (acosh z))
(define ($atanh z) (atanh z))
(define ($sqrt z) (sqrt z))
(define ($abs z) (abs z))
(define ($exp z) (exp z))
(define ($log z) (log z))
(define ($sin z) (sin z))
(define ($cos z) (cos z))
(define ($tan z) (tan z))
(define ($asin z) (asin z))
(define ($acos z) (acos z))
(define ($atan z) (atan z))
(define ($sinh z) (sinh z))
(define ($cosh z) (cosh z))
(define ($tanh z) (tanh z))

(define (closure? x)
  (issue-deprecation-warning
   "`closure?' is deprecated. Use `procedure?' instead.")
  (procedure? x))

(define %nil #nil)

;;; @bind is used by the old elisp code as a dynamic scoping mechanism.
;;; Please let the Guile developers know if you are using this macro.
;;;
(define-syntax @bind
  (lambda (x)
    (define (bound-member id ids)
      (cond ((null? ids) #f)
            ((bound-identifier=? id (car ids)) #t)
            ((bound-member (car ids) (cdr ids)))))

    (issue-deprecation-warning
     "`@bind' is deprecated. Use `with-fluids' instead.")

    (syntax-case x ()
      ((_ () b0 b1 ...)
       #'(let () b0 b1 ...))
      ((_ ((id val) ...) b0 b1 ...)
       (and-map identifier? #'(id ...))
       (if (let lp ((ids #'(id ...)))
             (cond ((null? ids) #f)
                   ((bound-member (car ids) (cdr ids)) #t)
                   (else (lp (cdr ids)))))
           (syntax-violation '@bind "duplicate bound identifier" x)
           (with-syntax (((old-v ...) (generate-temporaries #'(id ...)))
                         ((v ...) (generate-temporaries #'(id ...))))
             #'(let ((old-v id) ...
                     (v val) ...)
                 (dynamic-wind
                   (lambda ()
                     (set! id v) ...)
                   (lambda () b0 b1 ...)
                   (lambda ()
                     (set! id old-v) ...)))))))))

(define (module-ref-submodule module name)
  (or (hashq-ref (module-submodules module) name)
      (and (module-submodule-binder module)
           ((module-submodule-binder module) module name))
      (let ((var (module-local-variable module name)))
        (and (variable-bound? var)
             (module? (variable-ref var))
             (begin
               (warn "module" module "not in submodules table")
               (variable-ref var))))))

(define (module-define-submodule! module name submodule)
  (let ((var (module-local-variable module name)))
    (if (and var (variable-bound? var) (not (module? (variable-ref var))))
        (warn "defining module" module ": not overriding local definition" var)
        (module-define! module name submodule)))
  (hashq-set! (module-submodules module) name submodule))

;; Define (%app) and (%app modules), and have (app) alias (%app). This
;; side-effects the-root-module, both to the submodules table and (through
;; module-define-submodule! above) the obarray.
;;
(let ((%app (make-module 31)))
  (set-module-name! %app '(%app))
  (module-define-submodule! the-root-module '%app %app)
  (module-define-submodule! the-root-module 'app %app)
  (module-define-submodule! %app 'modules (resolve-module '() #f)))

;; Allow code that poked %module-public-interface to keep on working.
;;
(set! module-public-interface
      (let ((getter module-public-interface))
        (lambda (mod)
          (or (getter mod)
              (cond
               ((and=> (module-local-variable mod '%module-public-interface)
                       variable-ref)
                => (lambda (iface)
                     (issue-deprecation-warning
"Setting a module's public interface via munging %module-public-interface is
deprecated. Use set-module-public-interface! instead.")
                     (set-module-public-interface! mod iface)
                     iface))
               (else #f))))))

(set! set-module-public-interface!
      (let ((setter set-module-public-interface!))
        (lambda (mod iface)
          (setter mod iface)
          (module-define! mod '%module-public-interface iface))))

(define (bad-throw key . args)
  (issue-deprecation-warning
   "`bad-throw' in the default environment is deprecated.
Find it in the `(ice-9 scm-style-repl)' module instead.")
  (apply (@ (ice-9 scm-style-repl) bad-throw) key args))

(define (error-catching-loop thunk)
  (issue-deprecation-warning
   "`error-catching-loop' in the default environment is deprecated.
Find it in the `(ice-9 scm-style-repl)' module instead.")
  ((@ (ice-9 scm-style-repl) error-catching-loop) thunk))

(define (error-catching-repl r e p)
  (issue-deprecation-warning
   "`error-catching-repl' in the default environment is deprecated.
Find it in the `(ice-9 scm-style-repl)' module instead.")
  ((@ (ice-9 scm-style-repl) error-catching-repl) r e p))

(define (scm-style-repl)
  (issue-deprecation-warning
   "`scm-style-repl' in the default environment is deprecated.
Find it in the `(ice-9 scm-style-repl)' module instead, or
better yet, use the repl from `(system repl repl)'.")
  ((@ (ice-9 scm-style-repl) scm-style-repl)))

;;; Apply-to-args had the following comment attached to it in boot-9, but it's
;;; wrong-headed: in the mentioned case, a point should either be a record or
;;; multiple values.
;;;
;;; apply-to-args is functionally redundant with apply and, worse,
;;; is less general than apply since it only takes two arguments.
;;;
;;; On the other hand, apply-to-args is a syntacticly convenient way to
;;; perform binding in many circumstances when the "let" family of
;;; of forms don't cut it.  E.g.:
;;;
;;;     (apply-to-args (return-3d-mouse-coords)
;;;       (lambda (x y z)
;;;             ...))
;;;

(define (apply-to-args args fn)
  (issue-deprecation-warning
   "`apply-to-args' is deprecated. Include a local copy in your program.")
  (apply fn args))

(define (has-suffix? str suffix)
  (issue-deprecation-warning
   "`has-suffix?' is deprecated. Use `string-suffix?' instead (args reversed).")
  (string-suffix? suffix str))

(define scheme-file-suffix
  (lambda ()
    (issue-deprecation-warning
     "`scheme-file-suffix' is deprecated. Use `%load-extensions' instead.")
    ".scm"))

;;; {Command Line Options}
;;;

(define (get-option argv kw-opts kw-args return)
  (issue-deprecation-warning
   "`get-option' is deprecated. Use `(ice-9 getopt-long)' instead.")
  (cond
   ((null? argv)
    (return #f #f argv))

   ((or (not (eq? #\- (string-ref (car argv) 0)))
        (eq? (string-length (car argv)) 1))
    (return 'normal-arg (car argv) (cdr argv)))

   ((eq? #\- (string-ref (car argv) 1))
    (let* ((kw-arg-pos (or (string-index (car argv) #\=)
                           (string-length (car argv))))
           (kw (symbol->keyword (substring (car argv) 2 kw-arg-pos)))
           (kw-opt? (member kw kw-opts))
           (kw-arg? (member kw kw-args))
           (arg (or (and (not (eq? kw-arg-pos (string-length (car argv))))
                         (substring (car argv)
                                    (+ kw-arg-pos 1)
                                    (string-length (car argv))))
                    (and kw-arg?
                         (begin (set! argv (cdr argv)) (car argv))))))
      (if (or kw-opt? kw-arg?)
          (return kw arg (cdr argv))
          (return 'usage-error kw (cdr argv)))))

   (else
    (let* ((char (substring (car argv) 1 2))
           (kw (symbol->keyword char)))
      (cond

       ((member kw kw-opts)
        (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
               (new-argv (if (= 0 (string-length rest-car))
                             (cdr argv)
                             (cons (string-append "-" rest-car) (cdr argv)))))
          (return kw #f new-argv)))

       ((member kw kw-args)
        (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
               (arg (if (= 0 (string-length rest-car))
                        (cadr argv)
                        rest-car))
               (new-argv (if (= 0 (string-length rest-car))
                             (cddr argv)
                             (cdr argv))))
          (return kw arg new-argv)))

       (else (return 'usage-error kw argv)))))))

(define (for-next-option proc argv kw-opts kw-args)
  (issue-deprecation-warning
   "`for-next-option' is deprecated. Use `(ice-9 getopt-long)' instead.")
  (let loop ((argv argv))
    (get-option argv kw-opts kw-args
                (lambda (opt opt-arg argv)
                  (and opt (proc opt opt-arg argv loop))))))

(define (display-usage-report kw-desc)
  (issue-deprecation-warning
   "`display-usage-report' is deprecated. Use `(ice-9 getopt-long)' instead.")
  (for-each
   (lambda (kw)
     (or (eq? (car kw) #t)
         (eq? (car kw) 'else)
         (let* ((opt-desc kw)
                (help (cadr opt-desc))
                (opts (car opt-desc))
                (opts-proper (if (string? (car opts)) (cdr opts) opts))
                (arg-name (if (string? (car opts))
                              (string-append "<" (car opts) ">")
                              ""))
                (left-part (string-append
                            (with-output-to-string
                              (lambda ()
                                (map (lambda (x) (display (keyword->symbol x)) (display " "))
                                     opts-proper)))
                            arg-name))
                (middle-part (if (and (< (string-length left-part) 30)
                                      (< (string-length help) 40))
                                 (make-string (- 30 (string-length left-part)) #\ )
                                 "\n\t")))
           (display left-part)
           (display middle-part)
           (display help)
           (newline))))
   kw-desc))

(define (transform-usage-lambda cases)
  (issue-deprecation-warning
   "`display-usage-report' is deprecated. Use `(ice-9 getopt-long)' instead.")
  (let* ((raw-usage (delq! 'else (map car cases)))
         (usage-sans-specials (map (lambda (x)
                                    (or (and (not (list? x)) x)
                                        (and (symbol? (car x)) #t)
                                        (and (boolean? (car x)) #t)
                                        x))
                                  raw-usage))
         (usage-desc (delq! #t usage-sans-specials))
         (kw-desc (map car usage-desc))
         (kw-opts (apply append (map (lambda (x) (and (not (string? (car x))) x)) kw-desc)))
         (kw-args (apply append (map (lambda (x) (and (string? (car x)) (cdr x))) kw-desc)))
         (transmogrified-cases (map (lambda (case)
                                      (cons (let ((opts (car case)))
                                              (if (or (boolean? opts) (eq? 'else opts))
                                                  opts
                                                  (cond
                                                   ((symbol? (car opts))  opts)
                                                   ((boolean? (car opts)) opts)
                                                   ((string? (caar opts)) (cdar opts))
                                                   (else (car opts)))))
                                            (cdr case)))
                                    cases)))
    `(let ((%display-usage (lambda () (display-usage-report ',usage-desc))))
       (lambda (%argv)
         (let %next-arg ((%argv %argv))
           (get-option %argv
                       ',kw-opts
                       ',kw-args
                       (lambda (%opt %arg %new-argv)
                         (case %opt
                           ,@ transmogrified-cases))))))))

;;; {collect}
;;;
;;; Similar to `begin' but returns a list of the results of all constituent
;;; forms instead of the result of the last form.
;;;

(define-syntax collect
  (lambda (x)
    (issue-deprecation-warning
     "`collect' is deprecated. Define it yourself.")
    (syntax-case x ()
      ((_) #''())
      ((_ x x* ...)
       #'(let ((val x))
           (cons val (collect x* ...)))))))

(define (assert-repl-silence v)
  (issue-deprecation-warning
   "`assert-repl-silence' has moved to `(ice-9 scm-style-repl)'.")
  ((@ (ice-9 scm-style-repl) assert-repl-silence) v))

(define (assert-repl-print-unspecified v)
  (issue-deprecation-warning
   "`assert-repl-print-unspecified' has moved to `(ice-9 scm-style-repl)'.")
  ((@ (ice-9 scm-style-repl) assert-repl-print-unspecified) v))

(define (assert-repl-verbosity v)
  (issue-deprecation-warning
   "`assert-repl-verbosity' has moved to `(ice-9 scm-style-repl)'.")
  ((@ (ice-9 scm-style-repl) assert-repl-verbosity) v))

(define (set-repl-prompt! v)
  (issue-deprecation-warning
   "`set-repl-prompt!' is deprecated. Use `repl-default-prompt-set!' from
the `(system repl common)' module.")
  ;; Avoid @, as when bootstrapping it will cause the (system repl common)
  ;; module to be loaded at expansion time, which eventually loads srfi-1, but
  ;; that fails due to an unbuilt supporting lib... grrrrrrrrr.
  ((module-ref (resolve-interface '(system repl common))
               'repl-default-prompt-set!)
   v))

(define (set-batch-mode?! arg)
  (cond
   (arg
    (issue-deprecation-warning
     "`set-batch-mode?!' is deprecated. Use `ensure-batch-mode!' instead.")
    (ensure-batch-mode!))
   (else
    (issue-deprecation-warning
     "`set-batch-mode?!' with an argument of `#f' is deprecated. Use the
`*repl-stack*' fluid instead.")
    #t)))

(define (repl read evaler print)
  (issue-deprecation-warning
   "`repl' is deprecated. Define it yourself.")
  (let loop ((source (read (current-input-port))))
    (print (evaler source))
    (loop (read (current-input-port)))))

(define (pre-unwind-handler-dispatch key . args)
  (issue-deprecation-warning
   "`pre-unwind-handler-dispatch' is deprecated. Use
`default-pre-unwind-handler' from `(ice-9 scm-style-repl)' directly.")
  (apply (@ (ice-9 scm-style-repl) default-pre-unwind-handler) key args))

(define (default-pre-unwind-handler key . args)
  (issue-deprecation-warning
   "`default-pre-unwind-handler' is deprecated. Use it from
`(ice-9 scm-style-repl)' if you need it.")
  (apply (@ (ice-9 scm-style-repl) default-pre-unwind-handler) key args))

(define (handle-system-error key . args)
  (issue-deprecation-warning
   "`handle-system-error' is deprecated. Use it from
`(ice-9 scm-style-repl)' if you need it.")
  (apply (@ (ice-9 scm-style-repl) handle-system-error) key args))

(define-syntax stack-saved?
  (make-variable-transformer
   (lambda (x)
     (issue-deprecation-warning
      "`stack-saved?' is deprecated. Use it from
`(ice-9 save-stack)' if you need it.")
     (syntax-case x (set!)
       ((set! id val)
        (identifier? #'id)
        #'(set! (@ (ice-9 save-stack) stack-saved?) val))
       (id
        (identifier? #'id)
        #'(@ (ice-9 save-stack) stack-saved?))))))

(define-syntax the-last-stack
  (lambda (x)
    (issue-deprecation-warning
     "`the-last-stack' is deprecated. Use it from `(ice-9 save-stack)'
if you need it.")
    (syntax-case x ()
      (id
       (identifier? #'id)
       #'(@ (ice-9 save-stack) the-last-stack)))))

(define (save-stack . args)
  (issue-deprecation-warning
   "`save-stack' is deprecated. Use it from `(ice-9 save-stack)' if you need
it.")
  (apply (@ (ice-9 save-stack) save-stack) args))

(define (named-module-use! user usee)
  (issue-deprecation-warning
   "`named-module-use!' is deprecated. Define it yourself if you need it.")
  (module-use! (resolve-module user) (resolve-interface usee)))

(define (top-repl)
  (issue-deprecation-warning
   "`top-repl' has moved to the `(ice-9 top-repl)' module.")
  ((module-ref (resolve-module '(ice-9 top-repl)) 'top-repl)))


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

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

(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)
	   (procedure-documentation object))
      (object-property object 'documentation)
      (and (macro? object)
           (object-documentation (macro-transformer object)))
      (and (procedure? 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:
;;; -*- mode: scheme; coding: utf-8; -*-

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

;;; Commentary:

;;; Scheme eval, written in Scheme.
;;;
;;; Expressions are first expanded, by the syntax expander (i.e.
;;; psyntax), then memoized into internal forms. The evaluator itself
;;; only operates on the internal forms ("memoized expressions").
;;;
;;; Environments are represented as linked lists of the form (VAL ... .
;;; MOD). If MOD is #f, it means the environment was captured before
;;; modules were booted. If MOD is the literal value '(), we are
;;; evaluating at the top level, and so should track changes to the
;;; current module.
;;;
;;; Evaluate this in Emacs to make code indentation work right:
;;;
;;;    (put 'memoized-expression-case 'scheme-indent-function 1)
;;;

;;; Code:

(eval-when (compile)
  (define-syntax capture-env
    (syntax-rules ()
      ((_ (exp ...))
       (let ((env (exp ...)))
         (capture-env env)))
      ((_ env)
       (if (null? env)
           (current-module)
           (if (not env)
               ;; the and current-module checks that modules are booted,
               ;; and thus the-root-module is defined
               (and (current-module) the-root-module)
               env)))))

  ;; Fast case for procedures with fixed arities.
  (define-syntax make-fixed-closure
    (lambda (x)
      (define *max-static-argument-count* 8)
      (define (make-formals n)
        (map (lambda (i)
               (datum->syntax
                x
                (string->symbol
                 (string (integer->char (+ (char->integer #\a) i))))))
             (iota n)))
      (syntax-case x ()
        ((_ eval nreq body env) (not (identifier? #'env))
         #'(let ((e env))
             (make-fixed-closure eval nreq body e)))
        ((_ eval nreq body env)
         #`(case nreq
             #,@(map (lambda (nreq)
                       (let ((formals (make-formals nreq)))
                         #`((#,nreq)
                            (lambda (#,@formals)
                              (eval body
                                    (cons* #,@(reverse formals) env))))))
                     (iota *max-static-argument-count*))
             (else
              #,(let ((formals (make-formals *max-static-argument-count*)))
                  #`(lambda (#,@formals . more)
                      (let lp ((new-env (cons* #,@(reverse formals) env))
                               (nreq (- nreq #,*max-static-argument-count*))
                               (args more))
                        (if (zero? nreq)
                            (eval body
                                  (if (null? args)
                                      new-env
                                      (scm-error 'wrong-number-of-args
                                                 "eval" "Wrong number of arguments"
                                                 '() #f)))
                            (if (null? args)
                                (scm-error 'wrong-number-of-args
                                           "eval" "Wrong number of arguments"
                                           '() #f)
                                (lp (cons (car args) new-env)
                                    (1- nreq)
                                    (cdr args)))))))))))))

  (define-syntax call
    (lambda (x)
      (define *max-static-call-count* 4)
      (syntax-case x ()
        ((_ eval proc nargs args env) (identifier? #'env)
         #`(case nargs
             #,@(map (lambda (nargs)
                       #`((#,nargs)
                          (proc
                           #,@(map
                               (lambda (n)
                                 (let lp ((n n) (args #'args))
                                   (if (zero? n)
                                       #`(eval (car #,args) env)
                                       (lp (1- n) #`(cdr #,args)))))
                               (iota nargs)))))
                     (iota *max-static-call-count*))
             (else
              (apply proc
                     #,@(map
                         (lambda (n)
                           (let lp ((n n) (args #'args))
                             (if (zero? n)
                                 #`(eval (car #,args) env)
                                 (lp (1- n) #`(cdr #,args)))))
                         (iota *max-static-call-count*))
                     (let lp ((exps #,(let lp ((n *max-static-call-count*)
                                               (args #'args))
                                        (if (zero? n)
                                            args
                                            (lp (1- n) #`(cdr #,args)))))
                              (args '()))
                       (if (null? exps)
                           (reverse args)
                           (lp (cdr exps)
                               (cons (eval (car exps) env) args)))))))))))

  ;; This macro could be more straightforward if the compiler had better
  ;; copy propagation. As it is we do some copy propagation by hand.
  (define-syntax mx-bind
    (lambda (x)
      (syntax-case x ()
        ((_ data () body)
         #'body)
        ((_ data (a . b) body) (and (identifier? #'a) (identifier? #'b))
         #'(let ((a (car data))
                 (b (cdr data)))
             body))
        ((_ data (a . b) body) (identifier? #'a)
         #'(let ((a (car data))
                 (xb (cdr data)))
             (mx-bind xb b body)))
        ((_ data (a . b) body)
         #'(let ((xa (car data))
                 (xb (cdr data)))
             (mx-bind xa a (mx-bind xb b body))))
        ((_ data v body) (identifier? #'v)
         #'(let ((v data))
             body)))))

  ;; The resulting nested if statements will be an O(n) dispatch. Once
  ;; we compile `case' effectively, this situation will improve.
  (define-syntax mx-match
    (lambda (x)
      (syntax-case x (quote)
        ((_ mx data tag)
         #'(error "what" mx))
        ((_ mx data tag (('type pat) body) c* ...)
         #`(if (eqv? tag #,(or (memoized-typecode (syntax->datum #'type))
                               (error "not a typecode" #'type)))
               (mx-bind data pat body)
               (mx-match mx data tag c* ...))))))

  (define-syntax memoized-expression-case
    (lambda (x)
      (syntax-case x ()
        ((_ mx c ...)
         #'(let ((tag (memoized-expression-typecode mx))
                 (data (memoized-expression-data mx)))
             (mx-match mx data tag c ...)))))))

;;;
;;; On 18 Feb 2010, I did a profile of how often the various memoized expression
;;; types occur when getting to a prompt on a fresh build. Here are the numbers
;;; I got:
;;;
;;;      lexical-ref: 32933054
;;;             call: 20281547
;;;     toplevel-ref: 13228724
;;;               if: 9156156
;;;            quote: 6610137
;;;              let: 2619707
;;;           lambda: 1010921
;;;            begin: 948945
;;;      lexical-set: 509862
;;; call-with-values: 139668
;;;            apply: 49402
;;;       module-ref: 14468
;;;           define: 1259
;;;     toplevel-set: 328
;;;          dynwind: 162
;;;      with-fluids: 0
;;;          call/cc: 0
;;;       module-set: 0
;;;
;;; So until we compile `case' into a computed goto, we'll order the clauses in
;;; `eval' in this order, to put the most frequent cases first.
;;;

(define primitive-eval
  (let ()
    ;; We pre-generate procedures with fixed arities, up to some number of
    ;; arguments; see make-fixed-closure above.

    ;; A unique marker for unbound keywords.
    (define unbound-arg (list 'unbound-arg))

    ;; Procedures with rest, optional, or keyword arguments, potentially with
    ;; multiple arities, as with case-lambda.
    (define (make-general-closure env body nreq rest? nopt kw inits alt)
      (define alt-proc
        (and alt
             (let* ((body (car alt))
                    (nreq (cadr alt))
                    (rest (if (null? (cddr alt)) #f (caddr alt)))
                    (tail (and (pair? (cddr alt)) (pair? (cdddr alt)) (cdddr alt)))
                    (nopt (if tail (car tail) 0))
                    (kw (and tail (cadr tail)))
                    (inits (if tail (caddr tail) '()))
                    (alt (and tail (cadddr tail))))
               (make-general-closure env body nreq rest nopt kw inits alt))))
      (lambda %args
        (let lp ((env env)
                 (nreq* nreq)
                 (args %args))
          (if (> nreq* 0)
              ;; First, bind required arguments.
              (if (null? args)
                  (if alt
                      (apply alt-proc %args)
                      (scm-error 'wrong-number-of-args
                                 "eval" "Wrong number of arguments"
                                 '() #f))
                  (lp (cons (car args) env)
                      (1- nreq*)
                      (cdr args)))
              ;; Move on to optional arguments.
              (if (not kw)
                  ;; Without keywords, bind optionals from arguments.
                  (let lp ((env env)
                           (nopt nopt)
                           (args args)
                           (inits inits))
                    (if (zero? nopt)
                        (if rest?
                            (eval body (cons args env))
                            (if (null? args)
                                (eval body env)
                                (if alt
                                    (apply alt-proc %args)
                                    (scm-error 'wrong-number-of-args
                                               "eval" "Wrong number of arguments"
                                               '() #f))))
                        (if (null? args)
                            (lp (cons (eval (car inits) env) env)
                                (1- nopt) args (cdr inits))
                            (lp (cons (car args) env)
                                (1- nopt) (cdr args) (cdr inits)))))
                  ;; With keywords, we stop binding optionals at the first
                  ;; keyword.
                  (let lp ((env env)
                           (nopt* nopt)
                           (args args)
                           (inits inits))
                    (if (> nopt* 0)
                        (if (or (null? args) (keyword? (car args)))
                            (lp (cons (eval (car inits) env) env)
                                (1- nopt*) args (cdr inits))
                            (lp (cons (car args) env)
                                (1- nopt*) (cdr args) (cdr inits)))
                        ;; Finished with optionals.
                        (let* ((aok (car kw))
                               (kw (cdr kw))
                               (kw-base (+ nopt nreq (if rest? 1 0)))
                               (imax (let lp ((imax (1- kw-base)) (kw kw))
                                       (if (null? kw)
                                           imax
                                           (lp (max (cdar kw) imax)
                                               (cdr kw)))))
                               ;; Fill in kwargs  with "undefined" vals.
                               (env (let lp ((i kw-base)
                                             ;; Also, here we bind the rest
                                             ;; arg, if any.
                                             (env (if rest? (cons args env) env)))
                                      (if (<= i imax)
                                          (lp (1+ i) (cons unbound-arg env))
                                          env))))
                          ;; Now scan args for keywords.
                          (let lp ((args args))
                            (if (and (pair? args) (pair? (cdr args))
                                     (keyword? (car args)))
                                (let ((kw-pair (assq (car args) kw))
                                      (v (cadr args)))
                                  (if kw-pair
                                      ;; Found a known keyword; set its value.
                                      (list-set! env (- imax (cdr kw-pair)) v)
                                      ;; Unknown keyword.
                                      (if (not aok)
                                          (scm-error 'keyword-argument-error
                                                     "eval" "Unrecognized keyword"
                                                     '() #f)))
                                  (lp (cddr args)))
                                (if (pair? args)
                                    (if rest?
                                        ;; Be lenient parsing rest args.
                                        (lp (cdr args))
                                        (scm-error 'keyword-argument-error
                                                   "eval" "Invalid keyword"
                                                   '() #f))
                                    ;; Finished parsing keywords. Fill in
                                    ;; uninitialized kwargs by evalling init
                                    ;; expressions in their appropriate
                                    ;; environment.
                                    (let lp ((i (- imax kw-base))
                                             (inits inits))
                                      (if (pair? inits)
                                          (let ((tail (list-tail env i)))
                                            (if (eq? (car tail) unbound-arg)
                                                (set-car! tail
                                                          (eval (car inits)
                                                                (cdr tail))))
                                            (lp (1- i) (cdr inits)))
                                          ;; Finally, eval the body.
                                          (eval body env))))))))))))))

    ;; The "engine". EXP is a memoized expression.
    (define (eval exp env)
      (memoized-expression-case exp
        (('lexical-ref n)
         (list-ref env n))

        (('call (f nargs . args))
         (let ((proc (eval f env)))
           (call eval proc nargs args env)))

        (('toplevel-ref var-or-sym)
         (variable-ref
          (if (variable? var-or-sym)
              var-or-sym
              (memoize-variable-access! exp
                                        (capture-env (if (pair? env)
                                                         (cdr (last-pair env))
                                                         env))))))

        (('if (test consequent . alternate))
         (if (eval test env)
             (eval consequent env)
             (eval alternate env)))

        (('quote x)
         x)

        (('let (inits . body))
         (let lp ((inits inits) (new-env (capture-env env)))
           (if (null? inits)
               (eval body new-env)
               (lp (cdr inits)
                   (cons (eval (car inits) env) new-env)))))

        (('lambda (body nreq . tail))
         (if (null? tail)
             (make-fixed-closure eval nreq body (capture-env env))
             (if (null? (cdr tail))
                 (make-general-closure (capture-env env) body nreq (car tail)
                                       0 #f '() #f)
                 (apply make-general-closure (capture-env env) body nreq tail))))

        (('begin (first . rest))
         (let lp ((first first) (rest rest))
           (if (null? rest)
               (eval first env)
               (begin
                 (eval first env)
                 (lp (car rest) (cdr rest))))))

        (('lexical-set! (n . x))
         (let ((val (eval x env)))
           (list-set! env n val)))

        (('call-with-values (producer . consumer))
         (call-with-values (eval producer env)
           (eval consumer env)))

        (('apply (f args))
         (apply (eval f env) (eval args env)))

        (('module-ref var-or-spec)
         (variable-ref
          (if (variable? var-or-spec)
              var-or-spec
              (memoize-variable-access! exp #f))))

        (('define (name . x))
         (define! name (eval x env)))

        (('toplevel-set! (var-or-sym . x))
         (variable-set!
          (if (variable? var-or-sym)
              var-or-sym
              (memoize-variable-access! exp
                                        (capture-env (if (pair? env)
                                                         (cdr (last-pair env))
                                                         env))))
          (eval x env)))

        (('dynwind (in exp . out))
         (dynamic-wind (eval in env)
                       (lambda () (eval exp env))
                       (eval out env)))

        (('with-fluids (fluids vals . exp))
         (let* ((fluids (map (lambda (x) (eval x env)) fluids))
                (vals (map (lambda (x) (eval x env)) vals)))
           (let lp ((fluids fluids) (vals vals))
             (if (null? fluids)
                 (eval exp env)
                 (with-fluids (((car fluids) (car vals)))
                   (lp (cdr fluids) (cdr vals)))))))

        (('prompt (tag exp . handler))
         (@prompt (eval tag env)
                  (eval exp env)
                  (eval handler env)))

        (('call/cc proc)
         (call/cc (eval proc env)))

        (('module-set! (x . var-or-spec))
         (variable-set!
          (if (variable? var-or-spec)
              var-or-spec
              (memoize-variable-access! exp #f))
          (eval x env)))))

    ;; primitive-eval
    (lambda (exp)
      "Evaluate @var{exp} in the current module."
      (eval
       (memoize-expression
        (if (macroexpanded? exp)
            exp
            ((module-transformer (current-module)) exp)))
       '()))))