code:
(define-module (ice-9 gds-client)
  #:use-module (oop goops)
  #:use-module (oop goops describe)
  #:use-module (ice-9 debugging trace)
  #:use-module (ice-9 debugging traps)
  #:use-module (ice-9 debugging trc)
  #:use-module (ice-9 debugging steps)
  #:use-module (ice-9 pretty-print)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 session)
  #:use-module (ice-9 string-fun)
  #:export (gds-debug-trap
	    run-utility
	    gds-accept-input))

(cond ((string>=? (version) "1.7")
       (use-modules (ice-9 debugger utils)))
      (else
       (define the-ice-9-debugger-module (resolve-module '(ice-9 debugger)))
       (module-export! the-ice-9-debugger-module
		       '(source-position
			 write-frame-short/application
			 write-frame-short/expression
			 write-frame-args-long
			 write-frame-long))))

(use-modules (ice-9 debugger))

(define gds-port #f)

;; Return an integer that somehow identifies the current thread.
(define (get-thread-id)
  (let ((root (dynamic-root)))
    (cond ((integer? root)
	   root)
	  ((pair? root)
	   (object-address root))
	  (else
	   (error "Unexpected dynamic root:" root)))))

;; gds-debug-read is a high-priority read.  The (debug-thread-id ID)
;; form causes the frontend to dismiss any reads from threads whose id
;; is not ID, until it receives the (thread-id ...) form with the same
;; id as ID.  Dismissing the reads of any other threads (by sending a
;; form that is otherwise ignored) causes those threads to release the
;; read mutex, which allows the (gds-read) here to proceed.
(define (gds-debug-read)
  (write-form `(debug-thread-id ,(get-thread-id)))
  (gds-read))

(define (gds-debug-trap trap-context)
  "Invoke the GDS debugger to explore the stack at the specified trap."
  (connect-to-gds)
  (start-stack 'debugger
               (let* ((stack (tc:stack trap-context))
		      (flags1 (let ((trap-type (tc:type trap-context)))
				(case trap-type
				  ((#:return #:error)
				   (list trap-type
					 (tc:return-value trap-context)))
				  (else
				   (list trap-type)))))
		      (flags (if (tc:continuation trap-context)
				 (cons #:continuable flags1)
				 flags1))
		      (fired-traps (tc:fired-traps trap-context))
		      (special-index (and (= (length fired-traps) 1)
					  (is-a? (car fired-traps) <exit-trap>)
					  (eq? (tc:type trap-context) #:return)
					  (- (tc:depth trap-context)
					     (slot-ref (car fired-traps) 'depth)))))
                 ;; Write current stack to the frontend.
                 (write-form (list 'stack
				   (if (and special-index (> special-index 0))
				       special-index
				       0)
                                   (stack->emacs-readable stack)
                                   (append (flags->emacs-readable flags)
                                           (slot-ref trap-context
                                                     'handler-return-syms))))
		 ;; Now wait for instruction.
                 (let loop ((protocol (gds-debug-read)))
                   ;; Act on it.
                   (case (car protocol)
                     ((tweak)
		      ;; Request to tweak the handler return value.
		      (let ((tweaking (catch #t
					     (lambda ()
					       (list (with-input-from-string
							 (cadr protocol)
						       read)))
					     (lambda ignored #f))))
			(if tweaking
			    (slot-set! trap-context
				       'handler-return-value
				       (cons 'instead (car tweaking)))))
                      (loop (gds-debug-read)))
                     ((continue)
                      ;; Continue (by exiting the debugger).
                      *unspecified*)
                     ((evaluate)
                      ;; Evaluate expression in specified frame.
                      (eval-in-frame stack (cadr protocol) (caddr protocol))
                      (loop (gds-debug-read)))
                     ((info-frame)
                      ;; Return frame info.
                      (let ((frame (stack-ref stack (cadr protocol))))
                        (write-form (list 'info-result
                                          (with-output-to-string
                                            (lambda ()
                                              (write-frame-long frame))))))
                      (loop (gds-debug-read)))
                     ((info-args)
                      ;; Return frame args.
                      (let ((frame (stack-ref stack (cadr protocol))))
                        (write-form (list 'info-result
                                          (with-output-to-string
                                            (lambda ()
                                              (write-frame-args-long frame))))))
                      (loop (gds-debug-read)))
                     ((proc-source)
                      ;; Show source of application procedure.
                      (let* ((frame (stack-ref stack (cadr protocol)))
                             (proc (frame-procedure frame))
                             (source (and proc (procedure-source proc))))
                        (write-form (list 'info-result
                                          (if source
                                              (sans-surrounding-whitespace
                                               (with-output-to-string
                                                 (lambda ()
                                                   (pretty-print source))))
                                              (if proc
                                                  "This procedure is coded in C"
                                                  "This frame has no procedure")))))
                      (loop (gds-debug-read)))
		     ((traps-here)
		      ;; Show the traps that fired here.
		      (write-form (list 'info-result
					(with-output-to-string
					  (lambda ()
					    (for-each describe
						 (tc:fired-traps trap-context))))))
		      (loop (gds-debug-read)))
                     ((step-into)
                      ;; Set temporary breakpoint on next trap.
                      (at-step gds-debug-trap
                               1
			       #f
			       (if (memq #:return flags)
				   #f
				   (- (stack-length stack)
				      (cadr protocol)))))
                     ((step-over)
                      ;; Set temporary breakpoint on exit from
                      ;; specified frame.
                      (at-exit (- (stack-length stack) (cadr protocol))
                               gds-debug-trap))
                     ((step-file)
                      ;; Set temporary breakpoint on next trap in same
                      ;; source file.
                      (at-step gds-debug-trap
                               1
                               (frame-file-name (stack-ref stack
                                                           (cadr protocol)))
			       (if (memq #:return flags)
				   #f
				   (- (stack-length stack)
				      (cadr protocol)))))
                     (else
                      (safely-handle-nondebug-protocol protocol)
                      (loop (gds-debug-read))))))))

(define (connect-to-gds . application-name)
  (or gds-port
      (begin
        (set! gds-port
	      (or (let ((s (socket PF_INET SOCK_STREAM 0))
			(SOL_TCP 6)
			(TCP_NODELAY 1))
		    (setsockopt s SOL_TCP TCP_NODELAY 1)
		    (catch #t
			   (lambda ()
			     (connect s AF_INET (inet-aton "127.0.0.1") 8333)
			     s)
			   (lambda _ #f)))
		  (let ((s (socket PF_UNIX SOCK_STREAM 0)))
		    (catch #t
			   (lambda ()
			     (connect s AF_UNIX "/tmp/.gds_socket")
			     s)
			   (lambda _ #f)))
		  (error "Couldn't connect to GDS by TCP or Unix domain socket")))
        (write-form (list 'name (getpid) (apply client-name application-name))))))

(define (client-name . application-name)
  (let loop ((args (append application-name (program-arguments))))
    (if (null? args)
	(format #f "PID ~A" (getpid))
	(let ((arg (car args)))
	  (cond ((string-match "^(.*[/\\])?guile(\\..*)?$" arg)
		 (loop (cdr args)))
		((string-match "^-" arg)
		 (loop (cdr args)))
		(else
		 (format #f "~A (PID ~A)" arg (getpid))))))))

(if (not (defined? 'make-mutex))
    (begin
      (define (make-mutex) #f)
      (define lock-mutex noop)
      (define unlock-mutex noop)))

(define write-mutex (make-mutex))

(define (write-form form)
  ;; Write any form FORM to GDS.
  (lock-mutex write-mutex)
  (write form gds-port)
  (newline gds-port)
  (force-output gds-port)
  (unlock-mutex write-mutex))

(define (stack->emacs-readable stack)
  ;; Return Emacs-readable representation of STACK.
  (map (lambda (index)
	 (frame->emacs-readable (stack-ref stack index)))
       (iota (min (stack-length stack)
		  (cadr (memq 'depth (debug-options)))))))

(define (frame->emacs-readable frame)
  ;; Return Emacs-readable representation of FRAME.
  (if (frame-procedure? frame)
      (list 'application
	    (with-output-to-string
	     (lambda ()
	       (display (if (frame-real? frame) "  " "t "))
	       (write-frame-short/application frame)))
	    (source->emacs-readable frame))
      (list 'evaluation
	    (with-output-to-string
	     (lambda ()
	       (display (if (frame-real? frame) "  " "t "))
	       (write-frame-short/expression frame)))
	    (source->emacs-readable frame))))

(define (source->emacs-readable frame)
  ;; Return Emacs-readable representation of the filename, line and
  ;; column source properties of SOURCE.
  (or (frame->source-position frame) 'nil))

(define (flags->emacs-readable flags)
  ;; Return Emacs-readable representation of trap FLAGS.
  (let ((prev #f))
    (map (lambda (flag)
	   (let ((erf (if (and (keyword? flag)
			       (not (eq? prev #:return)))
			  (keyword->symbol flag)
			  (format #f "~S" flag))))
	     (set! prev flag)
	     erf))
	 flags)))

(define (eval-in-frame stack index expr)
  (write-form
   (list 'eval-result
         (format #f "~S"
                 (catch #t
                        (lambda ()
                          (local-eval (with-input-from-string expr read)
                                      (memoized-environment
                                       (frame-source (stack-ref stack
                                                                index)))))
                        (lambda args
                          (cons 'ERROR args)))))))

(set! (behaviour-ordering gds-debug-trap) 100)

;;; Code below here adds support for interaction between the GDS
;;; client program and the Emacs frontend even when not stopped in the
;;; debugger.

;; A mutex to control attempts by multiple threads to read protocol
;; back from the frontend.
(define gds-read-mutex (make-mutex))

;; Read a protocol instruction from the frontend.
(define (gds-read)
  ;; Acquire the read mutex.
  (lock-mutex gds-read-mutex)
  ;; Tell the front end something that identifies us as a thread.
  (write-form `(thread-id ,(get-thread-id)))
  ;; Now read, then release the mutex and return what was read.
  (let ((x (catch #t
		  (lambda () (read gds-port))
		  (lambda ignored the-eof-object))))
    (unlock-mutex gds-read-mutex)
    x))

(define (gds-accept-input exit-on-continue)
  ;; If reading from the GDS connection returns EOF, we will throw to
  ;; this catch.
  (catch 'server-eof
    (lambda ()
      (let loop ((protocol (gds-read)))
        (if (or (eof-object? protocol)
		(and exit-on-continue
		     (eq? (car protocol) 'continue)))
	    (throw 'server-eof))
        (safely-handle-nondebug-protocol protocol)
        (loop (gds-read))))
    (lambda ignored #f)))

(define (safely-handle-nondebug-protocol protocol)
  ;; This catch covers any internal errors in the GDS code or
  ;; protocol.
  (catch #t
    (lambda ()
      (lazy-catch #t
        (lambda ()
          (handle-nondebug-protocol protocol))
        save-lazy-trap-context-and-rethrow))
    (lambda (key . args)
      (write-form
       `(eval-results (error . ,(format #f "~s" protocol))
                      ,(if last-lazy-trap-context 't 'nil)
                      "GDS Internal Error
Please report this to <neil@ossau.uklinux.net>, ideally including:
- a description of the scenario in which this error occurred
- which versions of Guile and guile-debugging you are using
- the error stack, which you can get by clicking on the link below,
  and then cut and paste into your report.
Thanks!\n\n"
                      ,(list (with-output-to-string
                               (lambda ()
                                 (write key)
                                 (display ": ")
                                 (write args)
                                 (newline)))))))))

;; The key that is used to signal a read error changes from 1.6 to
;; 1.8; here we cover all eventualities by discovering the key
;; dynamically.
(define read-error-key
  (catch #t
    (lambda ()
      (with-input-from-string "(+ 3 4" read))
    (lambda (key . args)
      key)))

(define (handle-nondebug-protocol protocol)
  (case (car protocol)

    ((eval)
     (set! last-lazy-trap-context #f)
     (apply (lambda (correlator module port-name line column code flags)
              (with-input-from-string code
                (lambda ()
                  (set-port-filename! (current-input-port) port-name)
                  (set-port-line! (current-input-port) line)
                  (set-port-column! (current-input-port) column)
                  (let ((m (and module (resolve-module-from-root module))))
                    (catch read-error-key
                      (lambda ()
                        (let loop ((exprs '()) (x (read)))
                          (if (eof-object? x)
                              ;; Expressions to be evaluated have all
                              ;; been read.  Now evaluate them.
                              (let loop2 ((exprs (reverse! exprs))
                                          (results '())
                                          (n 1))
                                (if (null? exprs)
                                    (write-form `(eval-results ,correlator
                                                               ,(if last-lazy-trap-context 't 'nil)
                                                               ,@results))
                                    (loop2 (cdr exprs)
                                           (append results (gds-eval (car exprs) m
                                                                     (if (and (null? (cdr exprs))
                                                                              (= n 1))
                                                                         #f n)))
                                           (+ n 1))))
                              ;; Another complete expression read; add
                              ;; it to the list.
			      (begin
				(if (and (pair? x)
					 (memq 'debug flags))
				    (install-trap (make <source-trap>
						    #:expression x
						    #:behaviour gds-debug-trap)))
				(loop (cons x exprs) (read))))))
                      (lambda (key . args)
                        (write-form `(eval-results
                                      ,correlator
                                      ,(if last-lazy-trap-context 't 'nil)
                                      ,(with-output-to-string
                                         (lambda ()
                                           (display ";;; Reading expressions")
                                           (display " to evaluate\n")
                                           (apply display-error #f
                                                  (current-output-port) args)))
                                      ("error-in-read")))))))))
            (cdr protocol)))

    ((complete)
     (let ((matches (apropos-internal
		     (string-append "^" (regexp-quote (cadr protocol))))))
       (cond ((null? matches)
	      (write-form '(completion-result nil)))
	     (else
	      ;;(write matches (current-error-port))
	      ;;(newline (current-error-port))
	      (let ((match
		     (let loop ((match (symbol->string (car matches)))
				(matches (cdr matches)))
		       ;;(write match (current-error-port))
		       ;;(newline (current-error-port))
		       ;;(write matches (current-error-port))
		       ;;(newline (current-error-port))
		       (if (null? matches)
			   match
			   (if (string-prefix=? match
						(symbol->string (car matches)))
			       (loop match (cdr matches))
			       (loop (substring match 0
						(- (string-length match) 1))
				     matches))))))
		(if (string=? match (cadr protocol))
		    (write-form `(completion-result
				  ,(map symbol->string matches)))
		    (write-form `(completion-result
				  ,match))))))))

    ((debug-lazy-trap-context)
     (if last-lazy-trap-context
         (gds-debug-trap last-lazy-trap-context)
         (error "There is no stack available to show")))

    (else
     (error "Unexpected protocol:" protocol))))

(define (resolve-module-from-root name)
  (save-module-excursion
   (lambda ()
     (set-current-module the-root-module)
     (resolve-module name))))

(define (gds-eval x m part)
  ;; Consumer to accept possibly multiple values and present them for
  ;; Emacs as a list of strings.
  (define (value-consumer . values)
    (if (unspecified? (car values))
	'()
	(map (lambda (value)
	       (with-output-to-string (lambda () (write value))))
	     values)))
  ;; Now do evaluation.
  (let ((intro (if part
		   (format #f ";;; Evaluating expression ~A" part)
		   ";;; Evaluating"))
	(value #f))
    (let* ((do-eval (if m
			(lambda ()
			  (display intro)
			  (display " in module ")
			  (write (module-name m))
			  (newline)
			  (set! value
				(call-with-values (lambda ()
						    (start-stack 'gds-eval-stack
								 (eval x m)))
				  value-consumer)))
			(lambda ()
			  (display intro)
			  (display " in current module ")
			  (write (module-name (current-module)))
			  (newline)
			  (set! value
				(call-with-values (lambda ()
						    (start-stack 'gds-eval-stack
								 (primitive-eval x)))
				  value-consumer)))))
	   (output
	    (with-output-to-string
	     (lambda ()
	       (catch #t
                 (lambda ()
                   (lazy-catch #t
                     do-eval
                     save-lazy-trap-context-and-rethrow))
                 (lambda (key . args)
                   (case key
                     ((misc-error signal unbound-variable numerical-overflow)
                      (apply display-error #f
                             (current-output-port) args)
                      (set! value '("error-in-evaluation")))
                     (else
                      (display "EXCEPTION: ")
                      (display key)
                      (display " ")
                      (write args)
                      (newline)
                      (set! value
                            '("unhandled-exception-in-evaluation"))))))))))
      (list output value))))

(define last-lazy-trap-context #f)

(define (save-lazy-trap-context-and-rethrow key . args)
  (set! last-lazy-trap-context
	(throw->trap-context key args save-lazy-trap-context-and-rethrow))
  (apply throw key args))

(define (run-utility)
  (connect-to-gds)
  (write (getpid))
  (newline)
  (force-output)
  (named-module-use! '(guile-user) '(ice-9 session))
  (gds-accept-input #f))

(define-method (trap-description (trap <trap>))
  (let loop ((description (list (class-name (class-of trap))))
	     (next 'installed?))
    (case next
      ((installed?)
       (loop (if (slot-ref trap 'installed)
		 (cons 'installed description)
		 description)
	     'conditional?))
      ((conditional?)
       (loop (if (slot-ref trap 'condition)
		 (cons 'conditional description)
		 description)
	     'skip-count))
      ((skip-count)
       (loop (let ((skip-count (slot-ref trap 'skip-count)))
	       (if (zero? skip-count)
		   description
		   (cons* skip-count 'skip-count description)))
	     'single-shot?))
      ((single-shot?)
       (loop (if (slot-ref trap 'single-shot)
		 (cons 'single-shot description)
		 description)
	     'done))
      (else
       (reverse! description)))))

(define-method (trap-description (trap <procedure-trap>))
  (let ((description (next-method)))
    (set-cdr! description
	      (cons (procedure-name (slot-ref trap 'procedure))
		    (cdr description)))
    description))

(define-method (trap-description (trap <source-trap>))
  (let ((description (next-method)))
    (set-cdr! description
	      (cons (format #f "~s" (slot-ref trap 'expression))
		    (cdr description)))
    description))

(define-method (trap-description (trap <location-trap>))
  (let ((description (next-method)))
    (set-cdr! description
	      (cons* (slot-ref trap 'file-regexp)
		     (slot-ref trap 'line)
		     (slot-ref trap 'column)
		     (cdr description)))
    description))

(define (gds-trace-trap trap-context)
  (connect-to-gds)
  (gds-do-trace trap-context)
  (at-exit (tc:depth trap-context) gds-do-trace))

(define (gds-do-trace trap-context)
  (write-form (list 'trace
		    (format #f
			    "~3@a: ~a"
			    (trace/stack-real-depth trap-context)
			    (trace/info trap-context)))))

(define (gds-trace-subtree trap-context)
  (connect-to-gds)
  (gds-do-trace trap-context)
  (let ((step-trap (make <step-trap> #:behaviour gds-do-trace)))
    (install-trap step-trap)
    (at-exit (tc:depth trap-context)
	     (lambda (trap-context)
	       (uninstall-trap step-trap)))))

;;; (ice-9 gds-client) ends here.


code:
;;;; Guile Debugger UI server

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

(define-module (ice-9 gds-server)
  #:export (run-server))

;; UI is normally via a pipe to Emacs, so make sure to flush output
;; every time we write.
(define (write-to-ui form)
  (write form)
  (newline)
  (force-output))

(define (trc . args)
  (write-to-ui (cons '* args)))

(define (with-error->eof proc port)
  (catch #t
	 (lambda () (proc port))
	 (lambda args the-eof-object)))

(define connection->id (make-object-property))

(define (run-server port-or-path)

  (or (integer? port-or-path)
      (string? port-or-path)
      (error "port-or-path should be an integer (port number) or a string (file name)"
	     port-or-path))

  (let ((server (socket (if (integer? port-or-path) PF_INET PF_UNIX)
			SOCK_STREAM
			0)))

    ;; Initialize server socket.
    (if (integer? port-or-path)
	(begin
	  (setsockopt server SOL_SOCKET SO_REUSEADDR 1)
	  (bind server AF_INET INADDR_ANY port-or-path))
	(begin
	  (catch #t
		 (lambda () (delete-file port-or-path))
		 (lambda _ #f))
	  (bind server AF_UNIX port-or-path)))

    ;; Start listening.
    (listen server 5)

    (let loop ((clients '()) (readable-sockets '()))

      (define (do-read port)
	(cond ((eq? port (current-input-port))
	       (do-read-from-ui))
	      ((eq? port server)
	       (accept-new-client))
	      (else
	       (do-read-from-client port))))

      (define (do-read-from-ui)
	(trc "reading from ui")
	(let* ((form (with-error->eof read (current-input-port)))
	       (client (assq-ref (map (lambda (port)
					(cons (connection->id port) port))
				      clients)
				 (car form))))
	  (with-error->eof read-char (current-input-port))
	  (if client
	      (begin
		(write (cdr form) client)
		(newline client))
	      (trc "client not found")))
	clients)

      (define (accept-new-client)
        (let ((new-port (car (accept server))))
	  ;; Read the client's ID.
	  (let ((name-form (read new-port)))
	    ;; Absorb the following newline character.
	    (read-char new-port)
	    ;; Check that we have a name form.
	    (or (eq? (car name-form) 'name)
		(error "Invalid name form:" name-form))
	    ;; Store an association from the connection to the ID.
	    (set! (connection->id new-port) (cadr name-form))
	    ;; Pass the name form on to Emacs.
	    (write-to-ui (cons (connection->id new-port) name-form)))
	  ;; Add the new connection to the set that we select on.
          (cons new-port clients)))

      (define (do-read-from-client port)
	(trc "reading from client")
	(let ((next-char (with-error->eof peek-char port)))
	  ;;(trc 'next-char next-char)
	  (cond ((eof-object? next-char)
		 (write-to-ui (list (connection->id port) 'closed))
		 (close port)
		 (delq port clients))
		((char=? next-char #\()
		 (write-to-ui (cons (connection->id port)
				    (with-error->eof read port)))
		 clients)
		(else
		 (with-error->eof read-char port)
		 clients))))

      ;;(trc 'clients clients)
      ;;(trc 'readable-sockets readable-sockets)

      (if (null? readable-sockets)
	  (loop clients (car (select (cons (current-input-port)
					   (cons server clients))
				     '()
				     '())))
	  (loop (do-read (car readable-sockets)) (cdr readable-sockets))))))

;; What happens if there are multiple copies of Emacs running on the
;; same machine, and they all try to start up the GDS server?  They
;; can't all listen on the same TCP port, so the short answer is that
;; all of them except the first will get an EADDRINUSE error when
;; trying to bind.
;;
;; We want to be able to handle this scenario, though, so that Scheme
;; code can be evaluated, and help invoked, in any of those Emacsen.
;; So we introduce the idea of a "slave server".  When a new GDS
;; server gets an EADDRINUSE bind error, the implication is that there
;; is already a GDS server running, so the new server instead connects
;; to the existing one (by issuing a connect to the GDS port number).
;;
;; Let's call the first server the "master", and the new one the
;; "slave".  In principle the master can now proxy any GDS client
;; connections through to the slave, so long as there is sufficient
;; information in the protocol for it to decide when and how to do
;; this.
;;
;; The basic information and mechanism that we need for this is as
;; follows.
;;
;; - A unique ID for each Emacs; this can be each Emacs's PID.  When a
;; slave server connects to the master, it announces itself by sending
;; the protocol (emacs ID).
;;
;; - A way for a client to indicate which Emacs it wants to use.  At
;; the protocol level, this is an extra argument in the (name ...)
;; protocol.  (The absence of this argument means "no preference".  A
;; simplistic master server might then decide to use its own Emacs; a
;; cleverer one might monitor which Emacs appears to be most in use,
;; and use that one.)  At the API level this can be an optional
;; argument to the `gds-connect' procedure, and the Emacs GDS code
;; would obviously set this argument when starting a client from
;; within Emacs.
;;
;; We also want a strategy for continuing seamlessly if the master
;; server shuts down.
;;
;; - Each slave server will detect this as an error on the connection
;; to the master socket.  Each server then tries to bind to the GDS
;; port again (a race which the OS will resolve), and if that fails,
;; connect again.  The result of this is that there should be a new
;; master, and the others all slaves connected to the new master.
;;
;; - Each client will also detect this as an error on the connection
;; to the (master) server.  Either the client should try to connect
;; again (perhaps after a short delay), or the reconnection can be
;; delayed until the next time that the client requires the server.
;; (Probably the latter, all done within `gds-read'.)
;;
;; (Historical note: Before this master-slave idea, clients were
;; identified within gds-server.scm and gds*.el by an ID which was
;; actually the file descriptor of their connection to the server.
;; That is no good in the new scheme, because each client's ID must
;; persist when the master server changes, so we now use the client's
;; PID instead.  We didn't use PID before because the client/server
;; code was written to be completely asynchronous, which made it
;; tricky for the server to discover each client's PID and associate
;; it with a particular connection.  Now we solve that problem by
;; handling the initial protocol exchange synchronously.)
(define (run-slave-server port)
  'not-implemented)

license: unknown


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

;;; Author: Russ McManus (rewritten by Thien-Thi Nguyen)

;;; Commentary:

;;; This module implements some complex command line option parsing, in
;;; the spirit of the GNU C library function `getopt_long'.  Both long
;;; and short options are supported.
;;;
;;; The theory is that people should be able to constrain the set of
;;; options they want to process using a grammar, rather than some arbitrary
;;; structure.  The grammar makes the option descriptions easy to read.
;;;
;;; `getopt-long' is a procedure for parsing command-line arguments in a
;;; manner consistent with other GNU programs.  `option-ref' is a procedure
;;; that facilitates processing of the `getopt-long' return value.

;;; (getopt-long ARGS GRAMMAR)
;;; Parse the arguments ARGS according to the argument list grammar GRAMMAR.
;;;
;;; ARGS should be a list of strings.  Its first element should be the
;;; name of the program; subsequent elements should be the arguments
;;; that were passed to the program on the command line.  The
;;; `program-arguments' procedure returns a list of this form.
;;;
;;; GRAMMAR is a list of the form:
;;; ((OPTION (PROPERTY VALUE) ...) ...)
;;;
;;; Each OPTION should be a symbol.  `getopt-long' will accept a
;;; command-line option named `--OPTION'.
;;; Each option can have the following (PROPERTY VALUE) pairs:
;;;
;;;   (single-char CHAR) --- Accept `-CHAR' as a single-character
;;;		equivalent to `--OPTION'.  This is how to specify traditional
;;;		Unix-style flags.
;;;   (required? BOOL) --- If BOOL is true, the option is required.
;;;		getopt-long will raise an error if it is not found in ARGS.
;;;   (value BOOL) --- If BOOL is #t, the option accepts a value; if
;;;		it is #f, it does not; and if it is the symbol
;;;		`optional', the option may appear in ARGS with or
;;;		without a value.
;;;   (predicate FUNC) --- If the option accepts a value (i.e. you
;;;		specified `(value #t)' for this option), then getopt
;;;		will apply FUNC to the value, and throw an exception
;;;		if it returns #f.  FUNC should be a procedure which
;;;		accepts a string and returns a boolean value; you may
;;;		need to use quasiquotes to get it into GRAMMAR.
;;;
;;; The (PROPERTY VALUE) pairs may occur in any order, but each
;;; property may occur only once.  By default, options do not have
;;; single-character equivalents, are not required, and do not take
;;; values.
;;;
;;; In ARGS, single-character options may be combined, in the usual
;;; Unix fashion: ("-x" "-y") is equivalent to ("-xy").  If an option
;;; accepts values, then it must be the last option in the
;;; combination; the value is the next argument.  So, for example, using
;;; the following grammar:
;;;      ((apples    (single-char #\a))
;;;       (blimps    (single-char #\b) (value #t))
;;;       (catalexis (single-char #\c) (value #t)))
;;; the following argument lists would be acceptable:
;;;    ("-a" "-b" "bang" "-c" "couth")     ("bang" and "couth" are the values
;;;                                         for "blimps" and "catalexis")
;;;    ("-ab" "bang" "-c" "couth")         (same)
;;;    ("-ac" "couth" "-b" "bang")         (same)
;;;    ("-abc" "couth" "bang")             (an error, since `-b' is not the
;;;                                         last option in its combination)
;;;
;;; If an option's value is optional, then `getopt-long' decides
;;; whether it has a value by looking at what follows it in ARGS.  If
;;; the next element is does not appear to be an option itself, then
;;; that element is the option's value.
;;;
;;; The value of a long option can appear as the next element in ARGS,
;;; or it can follow the option name, separated by an `=' character.
;;; Thus, using the same grammar as above, the following argument lists
;;; are equivalent:
;;;   ("--apples" "Braeburn" "--blimps" "Goodyear")
;;;   ("--apples=Braeburn" "--blimps" "Goodyear")
;;;   ("--blimps" "Goodyear" "--apples=Braeburn")
;;;
;;; If the option "--" appears in ARGS, argument parsing stops there;
;;; subsequent arguments are returned as ordinary arguments, even if
;;; they resemble options.  So, in the argument list:
;;;         ("--apples" "Granny Smith" "--" "--blimp" "Goodyear")
;;; `getopt-long' will recognize the `apples' option as having the
;;; value "Granny Smith", but it will not recognize the `blimp'
;;; option; it will return the strings "--blimp" and "Goodyear" as
;;; ordinary argument strings.
;;;
;;; The `getopt-long' function returns the parsed argument list as an
;;; assocation list, mapping option names --- the symbols from GRAMMAR
;;; --- onto their values, or #t if the option does not accept a value.
;;; Unused options do not appear in the alist.
;;;
;;; All arguments that are not the value of any option are returned
;;; as a list, associated with the empty list.
;;;
;;; `getopt-long' throws an exception if:
;;; - it finds an unrecognized property in GRAMMAR
;;; - the value of the `single-char' property is not a character
;;; - it finds an unrecognized option in ARGS
;;; - a required option is omitted
;;; - an option that requires an argument doesn't get one
;;; - an option that doesn't accept an argument does get one (this can
;;;   only happen using the long option `--opt=value' syntax)
;;; - an option predicate fails
;;;
;;; So, for example:
;;;
;;; (define grammar
;;;   `((lockfile-dir (required? #t)
;;;                   (value #t)
;;;                   (single-char #\k)
;;;                   (predicate ,file-is-directory?))
;;;     (verbose (required? #f)
;;;              (single-char #\v)
;;;              (value #f))
;;;     (x-includes (single-char #\x))
;;;     (rnet-server (single-char #\y)
;;;                  (predicate ,string?))))
;;;
;;; (getopt-long '("my-prog" "-vk" "/tmp" "foo1" "--x-includes=/usr/include"
;;;                "--rnet-server=lamprod" "--" "-fred" "foo2" "foo3")
;;;                grammar)
;;; => ((() "foo1" "-fred" "foo2" "foo3")
;;; 	(rnet-server . "lamprod")
;;; 	(x-includes . "/usr/include")
;;; 	(lockfile-dir . "/tmp")
;;; 	(verbose . #t))

;;; (option-ref OPTIONS KEY DEFAULT)
;;; Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not
;;; found.  The value is either a string or `#t'.
;;;
;;; For example, using the `getopt-long' return value from above:
;;;
;;; (option-ref (getopt-long ...) 'x-includes 42) => "/usr/include"
;;; (option-ref (getopt-long ...) 'not-a-key! 31) => 31

;;; Code:

(define-module (ice-9 getopt-long)
  :use-module ((ice-9 common-list) :select (some remove-if-not))
  :export (getopt-long option-ref))

(define option-spec-fields '(name
                             value
                             required?
                             single-char
                             predicate
                             value-policy))

(define option-spec (make-record-type 'option-spec option-spec-fields))
(define make-option-spec (record-constructor option-spec option-spec-fields))

(define (define-one-option-spec-field-accessor field)
  `(define ,(symbol-append 'option-spec-> field)        ;;; name slib-compat
     (record-accessor option-spec ',field)))

(define (define-one-option-spec-field-modifier field)
  `(define ,(symbol-append 'set-option-spec- field '!)  ;;; name slib-compat
     (record-modifier option-spec ',field)))

(defmacro define-all-option-spec-accessors/modifiers ()
  `(begin
     ,@(map define-one-option-spec-field-accessor option-spec-fields)
     ,@(map define-one-option-spec-field-modifier option-spec-fields)))

(define-all-option-spec-accessors/modifiers)

(define make-option-spec
  (let ((ctor (record-constructor option-spec '(name))))
    (lambda (name)
      (ctor name))))

(define (parse-option-spec desc)
  (let ((spec (make-option-spec (symbol->string (car desc)))))
    (for-each (lambda (desc-elem)
                (let ((given (lambda () (cadr desc-elem))))
                  (case (car desc-elem)
                    ((required?)
                     (set-option-spec-required?! spec (given)))
                    ((value)
                     (set-option-spec-value-policy! spec (given)))
                    ((single-char)
                     (or (char? (given))
                         (error "`single-char' value must be a char!"))
                     (set-option-spec-single-char! spec (given)))
                    ((predicate)
                     (set-option-spec-predicate!
                      spec ((lambda (pred)
                              (lambda (name val)
                                (or (not val)
                                    (pred val)
                                    (error "option predicate failed:" name))))
                            (given))))
                    (else
                     (error "invalid getopt-long option property:"
                            (car desc-elem))))))
              (cdr desc))
    spec))

(define (split-arg-list argument-list)
  ;; Scan ARGUMENT-LIST for "--" and return (BEFORE-LS . AFTER-LS).
  ;; Discard the "--".  If no "--" is found, AFTER-LS is empty.
  (let loop ((yes '()) (no argument-list))
    (cond ((null? no)               (cons (reverse yes) no))
	  ((string=? "--" (car no)) (cons (reverse yes) (cdr no)))
	  (else (loop (cons (car no) yes) (cdr no))))))

(define short-opt-rx           (make-regexp "^-([a-zA-Z]+)(.*)"))
(define long-opt-no-value-rx   (make-regexp "^--([^=]+)$"))
(define long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)"))

(define (match-substring match which)
  ;; condensed from (ice-9 regex) `match:{substring,start,end}'
  (let ((sel (vector-ref match (1+ which))))
    (substring (vector-ref match 0) (car sel) (cdr sel))))

(define (expand-clumped-singles opt-ls)
  ;; example: ("--xyz" "-abc5d") => ("--xyz" "-a" "-b" "-c" "5d")
  (let loop ((opt-ls opt-ls) (ret-ls '()))
    (cond ((null? opt-ls)
           (reverse ret-ls))                                    ;;; retval
          ((regexp-exec short-opt-rx (car opt-ls))
           => (lambda (match)
                (let ((singles (reverse
                                (map (lambda (c)
                                       (string-append "-" (make-string 1 c)))
                                     (string->list
                                      (match-substring match 1)))))
                      (extra (match-substring match 2)))
                  (loop (cdr opt-ls)
                        (append (if (string=? "" extra)
                                    singles
                                    (cons extra singles))
                                ret-ls)))))
          (else (loop (cdr opt-ls)
                      (cons (car opt-ls) ret-ls))))))

(define (looks-like-an-option string)
  (some (lambda (rx)
          (regexp-exec rx string))
        `(,short-opt-rx
          ,long-opt-with-value-rx
          ,long-opt-no-value-rx)))

(define (process-options specs argument-ls)
  ;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC).
  ;; FOUND is an unordered list of option specs for found options, while ETC
  ;; is an order-maintained list of elements in ARGUMENT-LS that are neither
  ;; options nor their values.
  (let ((idx (map (lambda (spec)
                    (cons (option-spec->name spec) spec))
                  specs))
        (sc-idx (map (lambda (spec)
                       (cons (make-string 1 (option-spec->single-char spec))
                             spec))
                     (remove-if-not option-spec->single-char specs))))
    (let loop ((argument-ls argument-ls) (found '()) (etc '()))
      (let ((eat! (lambda (spec ls)
                    (let ((val!loop (lambda (val n-ls n-found n-etc)
                                      (set-option-spec-value!
                                       spec
                                       ;; handle multiple occurrances
                                       (cond ((option-spec->value spec)
                                              => (lambda (cur)
                                                   ((if (list? cur) cons list)
                                                    val cur)))
                                             (else val)))
                                      (loop n-ls n-found n-etc)))
                          (ERR:no-arg (lambda ()
                                        (error (string-append
                                                "option must be specified"
                                                " with argument:")
                                               (option-spec->name spec)))))
                      (cond
                       ((eq? 'optional (option-spec->value-policy spec))
                        (if (or (null? (cdr ls))
                                (looks-like-an-option (cadr ls)))
                            (val!loop #t
                                      (cdr ls)
                                      (cons spec found)
                                      etc)
                            (val!loop (cadr ls)
                                      (cddr ls)
                                      (cons spec found)
                                      etc)))
                       ((eq? #t (option-spec->value-policy spec))
                        (if (or (null? (cdr ls))
                                (looks-like-an-option (cadr ls)))
                            (ERR:no-arg)
                            (val!loop (cadr ls)
                                      (cddr ls)
                                      (cons spec found)
                                      etc)))
                       (else
                        (val!loop #t
                                  (cdr ls)
                                  (cons spec found)
                                  etc)))))))
        (if (null? argument-ls)
            (cons found (reverse etc))                          ;;; retval
            (cond ((regexp-exec short-opt-rx (car argument-ls))
                   => (lambda (match)
                        (let* ((c (match-substring match 1))
                               (spec (or (assoc-ref sc-idx c)
                                         (error "no such option:" c))))
                          (eat! spec argument-ls))))
                  ((regexp-exec long-opt-no-value-rx (car argument-ls))
                   => (lambda (match)
                        (let* ((opt (match-substring match 1))
                               (spec (or (assoc-ref idx opt)
                                         (error "no such option:" opt))))
                          (eat! spec argument-ls))))
                  ((regexp-exec long-opt-with-value-rx (car argument-ls))
                   => (lambda (match)
                        (let* ((opt (match-substring match 1))
                               (spec (or (assoc-ref idx opt)
                                         (error "no such option:" opt))))
                          (if (option-spec->value-policy spec)
                              (eat! spec (append
                                          (list 'ignored
                                                (match-substring match 2))
                                          (cdr argument-ls)))
                              (error "option does not support argument:"
                                     opt)))))
                  (else
                   (loop (cdr argument-ls)
                         found
                         (cons (car argument-ls) etc)))))))))

(define (getopt-long program-arguments option-desc-list)
  "Process options, handling both long and short options, similar to
the glibc function 'getopt_long'.  PROGRAM-ARGUMENTS should be a value
similar to what (program-arguments) returns.  OPTION-DESC-LIST is a
list of option descriptions.  Each option description must satisfy the
following grammar:

    <option-spec>           :: (<name> . <attribute-ls>)
    <attribute-ls>          :: (<attribute> . <attribute-ls>)
                               | ()
    <attribute>             :: <required-attribute>
                               | <arg-required-attribute>
                               | <single-char-attribute>
                               | <predicate-attribute>
                               | <value-attribute>
    <required-attribute>    :: (required? <boolean>)
    <single-char-attribute> :: (single-char <char>)
    <value-attribute>       :: (value #t)
                               (value #f)
                               (value optional)
    <predicate-attribute>   :: (predicate <1-ary-function>)

    The procedure returns an alist of option names and values.  Each
option name is a symbol.  The option value will be '#t' if no value
was specified.  There is a special item in the returned alist with a
key of the empty list, (): the list of arguments that are not options
or option values.
    By default, options are not required, and option values are not
required.  By default, single character equivalents are not supported;
if you want to allow the user to use single character options, you need
to add a `single-char' clause to the option description."
  (let* ((specifications (map parse-option-spec option-desc-list))
	 (pair (split-arg-list (cdr program-arguments)))
	 (split-ls (expand-clumped-singles (car pair)))
	 (non-split-ls (cdr pair))
         (found/etc (process-options specifications split-ls))
         (found (car found/etc))
         (rest-ls (append (cdr found/etc) non-split-ls)))
    (for-each (lambda (spec)
                (let ((name (option-spec->name spec))
                      (val (option-spec->value spec)))
                  (and (option-spec->required? spec)
                       (or (memq spec found)
                           (error "option must be specified:" name)))
                  (and (memq spec found)
                       (eq? #t (option-spec->value-policy spec))
                       (or val
                           (error "option must be specified with argument:"
                                  name)))
                  (let ((pred (option-spec->predicate spec)))
                    (and pred (pred name val)))))
              specifications)
    (cons (cons '() rest-ls)
          (let ((multi-count (map (lambda (desc)
                                    (cons (car desc) 0))
                                  option-desc-list)))
            (map (lambda (spec)
                   (let ((name (string->symbol (option-spec->name spec))))
                     (cons name
                           ;; handle multiple occurrances
                           (let ((maybe-ls (option-spec->value spec)))
                             (if (list? maybe-ls)
                                 (let* ((look (assq name multi-count))
                                        (idx (cdr look))
                                        (val (list-ref maybe-ls idx)))
                                   (set-cdr! look (1+ idx)) ; ugh!
                                   val)
                                 maybe-ls)))))
                 found)))))

(define (option-ref options key default)
  "Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not found.
The value is either a string or `#t'."
  (or (assq-ref options key) default))

;;; getopt-long.scm ends here


code:
;;; installed-scm-file

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

(define-module  (ice-9 hcons)
  :export (hashq-cons-hash hashq-cons-assoc hashq-cons-get-handle
	   hashq-cons-create-handle! hashq-cons-ref hashq-cons-set! hashq-cons
	   hashq-conser make-gc-buffer))

;;; {Eq? hash-consing}
;;;
;;; A hash conser maintains a private universe of pairs s.t. if
;;; two cons calls pass eq? arguments, the pairs returned are eq?.
;;;
;;; A hash conser does not contribute life to the pairs it returns.
;;;

(define (hashq-cons-hash pair n)
  (modulo (logxor (hashq (car pair) 4194303)
		  (hashq (cdr pair) 4194303))
	  n))

(define (hashq-cons-assoc key l)
  (and (not (null? l))
       (or (and (pair? l)		; If not a pair, use its cdr?
		(pair? (car l))
		(pair? (caar l))
		(eq? (car key) (caaar l))
		(eq? (cdr key) (cdaar l))
		(car l))
	   (hashq-cons-assoc key (cdr l)))))

(define (hashq-cons-get-handle table key)
  (hashx-get-handle hashq-cons-hash hashq-cons-assoc table key))

(define (hashq-cons-create-handle! table key init)
  (hashx-create-handle! hashq-cons-hash hashq-cons-assoc table key init))

(define (hashq-cons-ref table key)
  (hashx-ref hashq-cons-hash hashq-cons-assoc table key #f))

(define (hashq-cons-set! table key val)
  (hashx-set! hashq-cons-hash hashq-cons-assoc table key val))

(define (hashq-cons table a d)
  (car (hashq-cons-create-handle! table (cons a d) #f)))

(define (hashq-conser hash-tab-or-size)
  (let ((table (if (vector? hash-tab-or-size)
		   hash-tab-or-size
		   (make-doubly-weak-hash-table hash-tab-or-size))))
    (lambda (a d) (hashq-cons table a d))))

(define (make-gc-buffer n)
  (let ((ring (make-list n #f)))
    (append! ring ring)
    (lambda (next)
      (set-car! ring next)
      (set! ring (cdr ring))
      next)))


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

;;;; A simple value history support

(define-module (ice-9 history))

(process-define-module '((value-history)))

(define (use-value-history x)
  (module-use! (current-module)
	       (resolve-interface '(value-history))))

(define save-value-history
  (let ((count 0)
	(history (resolve-module '(value-history))))
    (lambda (v)
      (if (not (unspecified? v))
	  (let* ((c (1+ count))
		 (s (string->symbol (simple-format #f "$~A" c))))
	    (simple-format #t "~A = " s)
	    (module-define! history s v)
	    (module-export! history (list s))
	    (set! count c))))))

(add-hook! before-eval-hook use-value-history)
(add-hook! before-print-hook save-value-history)


code:
;;; installed-scm-file

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

(define-module (ice-9 lineio)
  :use-module (ice-9 readline)
  :export (unread-string read-string lineio-port?
	   make-line-buffering-input-port))

;;; {Line Buffering Input Ports}
;;;
;;; [This is a work-around to get past certain deficiencies in the capabilities
;;;  of ports.  Eventually, ports should be fixed and this module nuked.]
;;;
;;; A line buffering input port supports:
;;;
;;; 	read-string  	which returns the next line of input
;;;	unread-string 	which pushes a line back onto the stream
;;;
;;; The implementation of unread-string is kind of limited; it doesn't
;;; interact properly with unread-char, or any of the other port
;;; reading functions.  Only read-string will get you back the things that
;;; unread-string accepts.
;;;
;;; Normally a "line" is all characters up to and including a newline.
;;; If lines are put back using unread-string, they can be broken arbitrarily
;;; -- that is, read-string returns strings passed to unread-string (or
;;; shared substrings of them).
;;;

;; read-string port
;; unread-string port str
;;   Read (or buffer) a line from PORT.
;;
;; Not all ports support these functions -- only those with
;; 'unread-string and 'read-string properties, bound to hooks
;; implementing these functions.
;;
(define (unread-string str line-buffering-input-port)
  ((object-property line-buffering-input-port 'unread-string) str))

;;
(define (read-string line-buffering-input-port)
  ((object-property line-buffering-input-port 'read-string)))

(define (lineio-port? port)
  (not (not (object-property port 'read-string))))

;; make-line-buffering-input-port port
;;   Return a wrapper for PORT.  The wrapper handles read-string/unread-string.
;;
;; The port returned by this function reads newline terminated lines from PORT.
;; It buffers these characters internally, and parsels them out via calls
;; to read-char, read-string, and unread-string.
;;

(define (make-line-buffering-input-port underlying-port)
  (let* (;; buffers - a list of strings put back by unread-string or cached
	 ;; using read-line.
	 ;;
	 (buffers '())

	 ;; getc - return the next character from a buffer or from the underlying
	 ;; port.
	 ;;
	 (getc (lambda ()
		 (if (not buffers)
		     (read-char underlying-port)
		     (let ((c (string-ref (car buffers) 0)))
		       (if (= 1 (string-length (car buffers)))
			   (set! buffers (cdr buffers))
			   (set-car! buffers (substring (car buffers) 1)))
		       c))))

	 (propogate-close (lambda () (close-port underlying-port)))

	 (self (make-soft-port (vector #f #f #f getc propogate-close) "r"))

	 (unread-string (lambda (str)
			  (and (< 0 (string-length str))
				   (set! buffers (cons str buffers)))))

	 (read-string (lambda ()
		       (cond
			((not (null? buffers))
			 (let ((answer (car buffers)))
			   (set! buffers (cdr buffers))
			   answer))
			(else
			 (read-line underlying-port 'concat)))))) ;handle-newline->concat

    (set-object-property! self 'unread-string unread-string)
    (set-object-property! self 'read-string read-string)
    self))


code:
;;;; List functions not provided in R5RS or srfi-1

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

(define-module (ice-9 list)
  :export (rassoc rassv rassq))

(define (generic-rassoc key alist =)
  (let loop ((ls alist))
      (and (not (null? ls))
	   (if (= key (cdar ls))
	       (car ls)
	       (loop (cdr ls))))))

(define (rassoc key alist . =)
  (generic-rassoc key alist (if (null? =) equal? (car =))))

(define (rassv key alist)
  (generic-rassoc key alist eqv?))

(define (rassq key alist)
  (generic-rassoc key alist eq?))


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

(define-module (ice-9 ls)
  :use-module (ice-9 common-list)
  :export (local-definitions-in definitions-in ls lls
	   recursive-local-define))

;;;;
;;;	local-definitions-in root name
;;;		Returns a list of names defined locally in the named
;;;		subdirectory of root.
;;;	definitions-in root name
;;;		Returns a list of all names defined in the named
;;;		subdirectory of root.  The list includes alll locally
;;;		defined names as well as all names inherited from a
;;;		member of a use-list.
;;;
;;; A convenient interface for examining the nature of things:
;;;
;;;	ls . various-names
;;;
;;;		With no arguments, return a list of definitions in
;;;		`(current-module)'.
;;;
;;;		With just one argument, interpret that argument as the
;;;		name of a subdirectory of the current module and
;;;		return a list of names defined there.
;;;
;;;		With more than one argument, still compute
;;;		subdirectory lists, but return a list:
;;;			((<subdir-name> . <names-defined-there>)
;;;			 (<subdir-name> . <names-defined-there>)
;;;			 ...)
;;;
;;;     lls . various-names
;;;
;;;		Analogous to `ls', but with local definitions only.

(define (local-definitions-in root names)
  (let ((m (nested-ref root names))
	(answer '()))
    (if (not (module? m))
	(set! answer m)
	(module-for-each (lambda (k v) (set! answer (cons k answer))) m))
    answer))

(define (definitions-in root names)
  (let ((m (nested-ref root names)))
    (if (not (module? m))
	m
	(reduce union
		(cons (local-definitions-in m  '())
		      (map (lambda (m2) (definitions-in m2 '()))
			   (module-uses m)))))))

(define (ls . various-refs)
  (if (pair? various-refs)
       (if (cdr various-refs)
	   (map (lambda (ref)
		  (cons ref (definitions-in (current-module) ref)))
		various-refs)
	  (definitions-in (current-module) (car various-refs)))
      (definitions-in (current-module) '())))

(define (lls . various-refs)
  (if (pair? various-refs)
       (if (cdr various-refs)
	   (map (lambda (ref)
		  (cons ref (local-definitions-in (current-module) ref)))
		various-refs)
	  (local-definitions-in (current-module) (car various-refs)))
      (local-definitions-in (current-module) '())))

(define (recursive-local-define name value)
  (let ((parent (reverse! (cdr (reverse name)))))
    (and parent (make-modules-in (current-module) parent))
    (local-define name value)))

;;; ls.scm ends here


code:
;;; installed-scm-file

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

(define-module (ice-9 mapping)
  :use-module (ice-9 poe)
  :export (mapping-hooks-type make-mapping-hooks mapping-hooks?
	   mapping-hooks-get-handle mapping-hooks-create-handle
	   mapping-hooks-remove mapping-type make-mapping mapping?
	   mapping-hooks mapping-data set-mapping-hooks! set-mapping-data!
	   mapping-get-handle mapping-create-handle! mapping-remove!
	   mapping-ref mapping-set!  hash-table-mapping-hooks
	   make-hash-table-mapping hash-table-mapping))

(define mapping-hooks-type (make-record-type 'mapping-hooks '(get-handle
							      create-handle
							      remove)))

(define make-mapping-hooks (perfect-funcq 17 (record-constructor mapping-hooks-type)))
(define mapping-hooks? (record-predicate mapping-hooks-type))
(define mapping-hooks-get-handle (record-accessor mapping-hooks-type 'get-handle))
(define mapping-hooks-create-handle (record-accessor mapping-hooks-type 'create-handle))
(define mapping-hooks-remove (record-accessor mapping-hooks-type 'remove))

(define mapping-type (make-record-type 'mapping '(hooks data)))
(define make-mapping (record-constructor mapping-type))
(define mapping? (record-predicate mapping-type))
(define mapping-hooks (record-accessor mapping-type 'hooks))
(define mapping-data (record-accessor mapping-type 'data))
(define set-mapping-hooks! (record-modifier mapping-type 'hooks))
(define set-mapping-data! (record-modifier mapping-type 'data))

(define (mapping-get-handle map key)
  ((mapping-hooks-get-handle (mapping-hooks map)) map key))
(define (mapping-create-handle! map key . opts)
  (apply (mapping-hooks-create-handle (mapping-hooks map)) map key opts))
(define (mapping-remove! map key)
  ((mapping-hooks-remove (mapping-hooks map)) map key))

(define (mapping-ref map key . dflt)
  (cond
   ((mapping-get-handle map key)	=> cdr)
   (dflt				=> car)
   (else				#f)))

(define (mapping-set! map key val)
  (set-cdr! (mapping-create-handle! map key #f) val))

(define hash-table-mapping-hooks
  (let ((wrap (lambda (proc) (lambda (1st . rest) (apply proc (mapping-data 1st) rest)))))

    (perfect-funcq 17
		   (lambda (hash-proc assoc-proc delete-proc)
		     (let ((procs (list hash-proc assoc-proc delete-proc)))
		       (cond
			((equal? procs `(,hashq ,assq ,delq!))
			 (make-mapping-hooks (wrap hashq-get-handle)
					     (wrap hashq-create-handle!)
					     (wrap hashq-remove!)))
			((equal? procs `(,hashv ,assv ,delv!))
			 (make-mapping-hooks (wrap hashv-get-handle)
					     (wrap hashv-create-handle!)
					     (wrap hashv-remove!)))
			((equal? procs `(,hash ,assoc ,delete!))
			 (make-mapping-hooks (wrap hash-get-handle)
					     (wrap hash-create-handle!)
					     (wrap hash-remove!)))
			(else
			 (make-mapping-hooks (wrap
					      (lambda (table key)
						(hashx-get-handle hash-proc assoc-proc table key)))
					     (wrap
					      (lambda (table key)
						(hashx-create-handle hash-proc assoc-proc table key)))
					     (wrap
					      (lambda (table key)
						(hashx-get-handle hash-proc assoc-proc delete-proc table key)))))))))))

(define (make-hash-table-mapping table hash-proc assoc-proc delete-proc)
  (make-mapping (hash-table-mapping-hooks hash-proc assoc-proc delete-proc) table))

(define (hash-table-mapping . options)
  (let* ((size (or (and options (number? (car options)) (car options))
		   71))
	 (hash-proc (or (kw-arg-ref options #:hash-proc) hash))
	 (assoc-proc (or (kw-arg-ref options #:assoc-proc)
			 (cond
			  ((eq? hash-proc hash) assoc)
			  ((eq? hash-proc hashv) assv)
			  ((eq? hash-proc hashq) assq)
			  (else (error 'hash-table-mapping
				       "Hash-procedure specified with no known assoc function."
				       hash-proc)))))
	 (delete-proc (or (kw-arg-ref options #:delete-proc)
			  (cond
			   ((eq? hash-proc hash) delete!)
			   ((eq? hash-proc hashv) delv!)
			   ((eq? hash-proc hashq) delq!)
			   (else (error 'hash-table-mapping
					"Hash-procedure specified with no known delete function."
					hash-proc)))))
	 (table-constructor (or (kw-arg-ref options #:table-constructor)
				(lambda (len) (make-vector len '())))))
    (make-hash-table-mapping (table-constructor size)
			     hash-proc
			     assoc-proc
			     delete-proc)))


code:
;;; installed-scm-file

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

(define (gethostbyaddr addr) (gethost addr))
(define (gethostbyname name) (gethost name))

(define (getnetbyaddr addr) (getnet addr))
(define (getnetbyname name) (getnet name))

(define (getprotobyname name) (getproto name))
(define (getprotobynumber addr) (getproto addr))

(define (getservbyname name proto) (getserv name proto))
(define (getservbyport port proto) (getserv port proto))

(define (sethostent . stayopen)
  (if (pair? stayopen)
      (sethost (car stayopen))
      (sethost #f)))
(define (setnetent . stayopen)
  (if (pair? stayopen)
      (setnet (car stayopen))
      (setnet #f)))
(define (setprotoent . stayopen)
  (if (pair? stayopen)
      (setproto (car stayopen))
      (setproto #f)))
(define (setservent . stayopen)
  (if (pair? stayopen)
      (setserv (car stayopen))
      (setserv #f)))

(define (gethostent) (gethost))
(define (getnetent) (getnet))
(define (getprotoent) (getproto))
(define (getservent) (getserv))

(define (endhostent) (sethost))
(define (endnetent) (setnet))
(define (endprotoent) (setproto))
(define (endservent) (setserv))

(define (hostent:name obj) (vector-ref obj 0))
(define (hostent:aliases obj) (vector-ref obj 1))
(define (hostent:addrtype obj) (vector-ref obj 2))
(define (hostent:length obj) (vector-ref obj 3))
(define (hostent:addr-list obj) (vector-ref obj 4))

(define (netent:name obj) (vector-ref obj 0))
(define (netent:aliases obj) (vector-ref obj 1))
(define (netent:addrtype obj) (vector-ref obj 2))
(define (netent:net obj) (vector-ref obj 3))

(define (protoent:name obj) (vector-ref obj 0))
(define (protoent:aliases obj) (vector-ref obj 1))
(define (protoent:proto obj) (vector-ref obj 2))

(define (servent:name obj) (vector-ref obj 0))
(define (servent:aliases obj) (vector-ref obj 1))
(define (servent:port obj) (vector-ref obj 2))
(define (servent:proto obj) (vector-ref obj 3))

(define (sockaddr:fam obj) (vector-ref obj 0))
(define (sockaddr:path obj) (vector-ref obj 1))
(define (sockaddr:addr obj) (vector-ref obj 1))
(define (sockaddr:port obj) (vector-ref obj 2))
(define (sockaddr:flowinfo obj) (vector-ref obj 3))
(define (sockaddr:scopeid obj) (vector-ref obj 4))


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

;;;; The null environment - only syntactic bindings

(define-module (ice-9 null)
  :use-module (ice-9 syncase)
  :re-export-syntax (define quote lambda if set!

		     cond case and or

		     let let* letrec

		     begin do

		     delay

		     quasiquote

		     define-syntax
		     let-syntax letrec-syntax))


code:
;;;; Occam-like channels

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

(define-module (ice-9 occam-channel)
  #:use-syntax (ice-9 syncase)
  #:use-module (oop goops)
  #:use-module (ice-9 threads)
  #:export-syntax (alt
		   ;; macro use:
		   oc:lock oc:unlock oc:consequence
		   oc:immediate-dispatch oc:late-dispatch oc:first-channel
		   oc:set-handshake-channel oc:unset-handshake-channel)
  #:export (make-channel
	    ?
	    !
	    make-timer
	    ;; macro use:
	    handshake-channel mutex
	    sender-waiting?
	    immediate-receive late-receive
	    )
  )

(define no-data '(no-data))
(define receiver-waiting '(receiver-waiting))

(define-class <channel> ())

(define-class <data-channel> (<channel>)
  (handshake-channel #:accessor handshake-channel)
  (data #:accessor data #:init-value no-data)
  (cv #:accessor cv #:init-form (make-condition-variable))
  (mutex #:accessor mutex #:init-form (make-mutex)))

(define-method (initialize (ch <data-channel>) initargs)
  (next-method)
  (set! (handshake-channel ch) ch))

(define-method (make-channel)
  (make <data-channel>))

(define-method (sender-waiting? (ch <data-channel>))
  (not (eq? (data ch) no-data)))

(define-method (receiver-waiting? (ch <data-channel>))
  (eq? (data ch) receiver-waiting))

(define-method (immediate-receive (ch <data-channel>))
  (signal-condition-variable (cv ch))
  (let ((res (data ch)))
    (set! (data ch) no-data)
    res))

(define-method (late-receive (ch <data-channel>))
  (let ((res (data ch)))
    (set! (data ch) no-data)
    res))

(define-method (? (ch <data-channel>))
  (lock-mutex (mutex ch))
  (let ((res (cond ((receiver-waiting? ch)
		    (unlock-mutex (mutex ch))
		    (scm-error 'misc-error '?
			       "another process is already receiving on ~A"
			       (list ch) #f))
		   ((sender-waiting? ch)
		    (immediate-receive ch))
		   (else
		    (set! (data ch) receiver-waiting)
		    (wait-condition-variable (cv ch) (mutex ch))
		    (late-receive ch)))))
    (unlock-mutex (mutex ch))
    res))

(define-method (! (ch <data-channel>))
  (! ch *unspecified*))

(define-method (! (ch <data-channel>) (x <top>))
  (lock-mutex (mutex (handshake-channel ch)))
  (cond ((receiver-waiting? ch)
	 (set! (data ch) x)
	 (signal-condition-variable (cv (handshake-channel ch))))
	((sender-waiting? ch)
	 (unlock-mutex (mutex (handshake-channel ch)))
	 (scm-error 'misc-error '! "another process is already sending on ~A"
		    (list ch) #f))
	(else
	 (set! (data ch) x)
	 (wait-condition-variable (cv ch) (mutex ch))))
  (unlock-mutex (mutex (handshake-channel ch))))

;;; Add protocols?

(define-class <port-channel> (<channel>)
  (port #:accessor port #:init-keyword #:port))

(define-method (make-channel (port <port>))
  (make <port-channel> #:port port))

(define-method (? (ch <port-channel>))
  (read (port ch)))

(define-method (! (ch <port-channel>))
  (write (port ch)))

(define-class <timer-channel> (<channel>))

(define the-timer (make <timer-channel>))

(define timer-cv (make-condition-variable))
(define timer-mutex (make-mutex))

(define (make-timer)
  the-timer)

(define (timeofday->us t)
  (+ (* 1000000 (car t)) (cdr t)))

(define (us->timeofday n)
  (cons (quotient n 1000000)
	(remainder n 1000000)))

(define-method (? (ch <timer-channel>))
  (timeofday->us (gettimeofday)))

(define-method (? (ch <timer-channel>) (t <integer>))
  (lock-mutex timer-mutex)
  (wait-condition-variable timer-cv timer-mutex (us->timeofday t))
  (unlock-mutex timer-mutex))

;;; (alt CLAUSE ...)
;;;
;;; CLAUSE ::= ((? CH) FORM ...)
;;;            | (EXP (? CH) FORM ...)
;;;            | (EXP FORM ...)
;;;
;;; where FORM ... can be => (lambda (x) ...)
;;;
;;; *fixme* Currently only handles <data-channel>:s
;;;

(define-syntax oc:lock
  (syntax-rules (?)
    ((_ ((? ch) form ...)) (lock-mutex (mutex ch)))
    ((_ (exp (? ch) form ...)) (lock-mutex (mutex ch)))
    ((_ (exp form ...)) #f)))

(define-syntax oc:unlock
  (syntax-rules (?)
    ((_ ((? ch) form ...)) (unlock-mutex (mutex ch)))
    ((_ (exp (? ch) form ...)) (unlock-mutex (mutex ch)))
    ((_ (exp form ...)) #f)))

(define-syntax oc:consequence
  (syntax-rules (=>)
    ((_ data) data)
    ((_ data => (lambda (x) e1 e2 ...))
     (let ((x data)) e1 e2 ...))
    ((_ data e1 e2 ...)
     (begin data e1 e2 ...))))

(define-syntax oc:immediate-dispatch
  (syntax-rules (?)
    ((_ ((? ch) e1 ...))
     ((sender-waiting? ch)
      (oc:consequence (immediate-receive ch) e1 ...)))
    ((_ (exp (? ch) e1 ...))
     ((and exp (sender-waiting? ch))
      (oc:consequence (immediate-receive ch) e1 ...)))
    ((_ (exp e1 ...))
     (exp e1 ...))))

(define-syntax oc:late-dispatch
  (syntax-rules (?)
    ((_ ((? ch) e1 ...))
     ((sender-waiting? ch)
      (oc:consequence (late-receive ch) e1 ...)))
    ((_ (exp (? ch) e1 ...))
     ((and exp (sender-waiting? ch))
      (oc:consequence (late-receive ch) e1 ...)))
    ((_ (exp e1 ...))
     (#f))))

(define-syntax oc:first-channel
  (syntax-rules (?)
    ((_ ((? ch) e1 ...) c2 ...)
     ch)
    ((_ (exp (? ch) e1 ...) c2 ...)
     ch)
    ((_ c1 c2 ...)
     (first-channel c2 ...))))

(define-syntax oc:set-handshake-channel
  (syntax-rules (?)
    ((_ ((? ch) e1 ...) handshake)
     (set! (handshake-channel ch) handshake))
    ((_ (exp (? ch) e1 ...) handshake)
     (and exp (set! (handshake-channel ch) handshake)))
    ((_ (exp e1 ...) handshake)
     #f)))

(define-syntax oc:unset-handshake-channel
  (syntax-rules (?)
    ((_ ((? ch) e1 ...))
     (set! (handshake-channel ch) ch))
    ((_ (exp (? ch) e1 ...))
     (and exp (set! (handshake-channel ch) ch)))
    ((_ (exp e1 ...))
     #f)))

(define-syntax alt
  (lambda (x)
    (define (else-clause? x)
      (syntax-case x (else)
	((_) #f)
	((_ (else e1 e2 ...)) #t)
	((_ c1 c2 ...) (else-clause? (syntax (_ c2 ...))))))

    (syntax-case x (else)
      ((_ c1 c2 ...)
       (else-clause? x)
       (syntax (begin
		 (oc:lock c1)
		 (oc:lock c2) ...
		 (let ((res (cond (oc:immediate-dispatch c1)
				  (oc:immediate-dispatch c2) ...)))
		   (oc:unlock c1)
		   (oc:unlock c2) ...
		   res))))
      ((_ c1 c2 ...)
       (syntax (begin
		 (oc:lock c1)
		 (oc:lock c2) ...
		 (let ((res (cond (oc:immediate-dispatch c1)
				  (oc:immediate-dispatch c2) ...
				  (else (let ((ch (oc:first-channel c1 c2 ...)))
					  (oc:set-handshake-channel c1 ch)
					  (oc:set-handshake-channel c2 ch) ...
					  (wait-condition-variable (cv ch)
								   (mutex ch))
					  (oc:unset-handshake-channel c1)
					  (oc:unset-handshake-channel c2) ...
					  (cond (oc:late-dispatch c1)
						(oc:late-dispatch c2) ...))))))
		   (oc:unlock c1)
		   (oc:unlock c2) ...
		   res)))))))


code:
;;;; optargs.scm -- support for optional arguments
;;;;
;;;; 	Copyright (C) 1997, 1998, 1999, 2001, 2002, 2004, 2006 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
;;;; Contributed by Maciej Stachowiak <mstachow@alum.mit.edu>

;;; Commentary:

;;; {Optional Arguments}
;;;
;;; The C interface for creating Guile procedures has a very handy
;;; "optional argument" feature. This module attempts to provide
;;; similar functionality for procedures defined in Scheme with
;;; a convenient and attractive syntax.
;;;
;;; exported macros are:
;;;   let-optional
;;;   let-optional*
;;;   let-keywords
;;;   let-keywords*
;;;   lambda*
;;;   define*
;;;   define*-public
;;;   defmacro*
;;;   defmacro*-public
;;;
;;;
;;; Summary of the lambda* extended parameter list syntax (brackets
;;; are used to indicate grouping only):
;;;
;;; ext-param-list ::= [identifier]* [#:optional [ext-var-decl]+]?
;;;   [#:key [ext-var-decl]+ [#:allow-other-keys]?]?
;;;   [[#:rest identifier]|[. identifier]]?
;;;
;;; ext-var-decl ::= identifier | ( identifier expression )
;;;
;;; The characters `*', `+' and `?' are not to be taken literally; they
;;; mean respectively, zero or more occurences, one or more occurences,
;;; and one or zero occurences.
;;;

;;; Code:

(define-module (ice-9 optargs)
  :export-syntax (let-optional
		  let-optional*
		  let-keywords
		  let-keywords*
		  define* lambda*
		  define*-public
		  defmacro*
		  defmacro*-public))

;; let-optional rest-arg (binding ...) . body
;; let-optional* rest-arg (binding ...) . body
;;   macros used to bind optional arguments
;;
;; These two macros give you an optional argument interface that is
;; very "Schemey" and introduces no fancy syntax. They are compatible
;; with the scsh macros of the same name, but are slightly
;; extended. Each of binding may be of one of the forms <var> or
;; (<var> <default-value>). rest-arg should be the rest-argument of
;; the procedures these are used from. The items in rest-arg are
;; sequentially bound to the variable namess are given. When rest-arg
;; runs out, the remaining vars are bound either to the default values
;; or to `#f' if no default value was specified. rest-arg remains
;; bound to whatever may have been left of rest-arg.
;;

(defmacro let-optional (REST-ARG BINDINGS . BODY)
  (let-optional-template REST-ARG BINDINGS BODY 'let))

(defmacro let-optional* (REST-ARG BINDINGS . BODY)
  (let-optional-template REST-ARG BINDINGS BODY 'let*))

;; let-keywords rest-arg allow-other-keys? (binding ...) . body
;; let-keywords* rest-arg allow-other-keys? (binding ...) . body
;;   macros used to bind keyword arguments
;;
;; These macros pick out keyword arguments from rest-arg, but do not
;; modify it. This is consistent at least with Common Lisp, which
;; duplicates keyword args in the rest arg. More explanation of what
;; keyword arguments in a lambda list look like can be found below in
;; the documentation for lambda*.  Bindings can have the same form as
;; for let-optional. If allow-other-keys? is false, an error will be
;; thrown if anything that looks like a keyword argument but does not
;; match a known keyword parameter will result in an error.
;;

(defmacro let-keywords (REST-ARG ALLOW-OTHER-KEYS? BINDINGS . BODY)
  (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY 'let))

(defmacro let-keywords* (REST-ARG ALLOW-OTHER-KEYS? BINDINGS . BODY)
  (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY 'let*))

;; some utility procedures for implementing the various let-forms.

(define (let-o-k-template REST-ARG BINDINGS BODY let-type proc)
  (let ((bindings (map (lambda (x)
			 (if (list? x)
			     x
			     (list x #f)))
		       BINDINGS)))
    `(,let-type ,(map proc bindings) ,@BODY)))

(define (let-optional-template REST-ARG BINDINGS BODY let-type)
    (if (null? BINDINGS)
	`(let () ,@BODY)
	(let-o-k-template REST-ARG BINDINGS BODY let-type
			  (lambda (optional)
			    `(,(car optional)
			      (cond
			       ((not (null? ,REST-ARG))
				(let ((result (car ,REST-ARG)))
				  ,(list 'set! REST-ARG
					 `(cdr ,REST-ARG))
				  result))
			       (else
				,(cadr optional))))))))

(define (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY let-type)
    (if (null? BINDINGS)
	`(let () ,@BODY)
	(let* ((kb-list-gensym (gensym "kb:G"))
	       (bindfilter (lambda (key)
			     `(,(car key)
			       (cond
				((assq ',(car key) ,kb-list-gensym)
				 => cdr)
				(else
				 ,(cadr key)))))))
	  `(let* ((ra->kbl ,rest-arg->keyword-binding-list)
		  (,kb-list-gensym (ra->kbl ,REST-ARG ',(map
							 (lambda (x) (symbol->keyword (if (pair? x) (car x) x)))
							 BINDINGS)
					    ,ALLOW-OTHER-KEYS?)))
	     ,(let-o-k-template REST-ARG BINDINGS BODY let-type bindfilter)))))

(define (rest-arg->keyword-binding-list rest-arg keywords allow-other-keys?)
  (if (null? rest-arg)
      '()
      (let loop ((first (car rest-arg))
		 (rest (cdr rest-arg))
		 (accum '()))
	(let ((next (lambda (a)
		      (if (null? (cdr rest))
			  a
			  (loop (cadr rest) (cddr rest) a)))))
	  (if (keyword? first)
	      (cond
	       ((memq first keywords)
		(if (null? rest)
		    (error "Keyword argument has no value.")
		    (next (cons (cons (keyword->symbol first)
				      (car rest)) accum))))
	       ((not allow-other-keys?)
		(error "Unknown keyword in arguments."))
	       (else (if (null? rest)
			 accum
			 (next accum))))
	      (if (null? rest)
		  accum
		  (loop (car rest) (cdr rest) accum)))))))

;; lambda* args . body
;;   lambda extended for optional and keyword arguments
;;
;; lambda* creates a procedure that takes optional arguments. These
;; are specified by putting them inside brackets at the end of the
;; paramater list, but before any dotted rest argument. For example,
;;   (lambda* (a b #:optional c d . e) '())
;; creates a procedure with fixed arguments a and b, optional arguments c
;; and d, and rest argument e. If the optional arguments are omitted
;; in a call, the variables for them are bound to `#f'.
;;
;; lambda* can also take keyword arguments. For example, a procedure
;; defined like this:
;;   (lambda* (#:key xyzzy larch) '())
;; can be called with any of the argument lists (#:xyzzy 11)
;; (#:larch 13) (#:larch 42 #:xyzzy 19) (). Whichever arguments
;; are given as keywords are bound to values.
;;
;; Optional and keyword arguments can also be given default values
;; which they take on when they are not present in a call, by giving a
;; two-item list in place of an optional argument, for example in:
;;   (lambda* (foo #:optional (bar 42) #:key (baz 73)) (list foo bar baz))
;; foo is a fixed argument, bar is an optional argument with default
;; value 42, and baz is a keyword argument with default value 73.
;; Default value expressions are not evaluated unless they are needed
;; and until the procedure is called.
;;
;; lambda* now supports two more special parameter list keywords.
;;
;; lambda*-defined procedures now throw an error by default if a
;; keyword other than one of those specified is found in the actual
;; passed arguments. However, specifying #:allow-other-keys
;; immediately after the keyword argument declarations restores the
;; previous behavior of ignoring unknown keywords. lambda* also now
;; guarantees that if the same keyword is passed more than once, the
;; last one passed is the one that takes effect. For example,
;;   ((lambda* (#:key (heads 0) (tails 0)) (display (list heads tails)))
;;    #:heads 37 #:tails 42 #:heads 99)
;; would result in (99 47) being displayed.
;;
;; #:rest is also now provided as a synonym for the dotted syntax rest
;; argument. The argument lists (a . b) and (a #:rest b) are equivalent in
;; all respects to lambda*. This is provided for more similarity to DSSSL,
;; MIT-Scheme and Kawa among others, as well as for refugees from other
;; Lisp dialects.

(defmacro lambda* (ARGLIST . BODY)
  (parse-arglist
   ARGLIST
   (lambda (non-optional-args optionals keys aok? rest-arg)
     ;; Check for syntax errors.
     (if (not (every? symbol? non-optional-args))
	 (error "Syntax error in fixed argument declaration."))
     (if (not (every? ext-decl? optionals))
	 (error "Syntax error in optional argument declaration."))
     (if (not (every? ext-decl? keys))
	 (error "Syntax error in keyword argument declaration."))
     (if (not (or (symbol? rest-arg) (eq? #f rest-arg)))
	 (error "Syntax error in rest argument declaration."))
     ;; generate the code.
     (let ((rest-gensym (or rest-arg (gensym "lambda*:G")))
	   (lambda-gensym (gensym "lambda*:L")))
       (if (not (and (null? optionals) (null? keys)))
	   `(let ((,lambda-gensym
		   (lambda (,@non-optional-args . ,rest-gensym)
		     ;; Make sure that if the proc had a docstring, we put it
		     ;; here where it will be visible.
		     ,@(if (and (not (null? BODY))
				(string? (car BODY)))
			   (list (car BODY))
			   '())
		     (let-optional*
		      ,rest-gensym
		      ,optionals
		      (let-keywords* ,rest-gensym
				     ,aok?
				     ,keys
				     ,@(if (and (not rest-arg) (null? keys))
					   `((if (not (null? ,rest-gensym))
						 (error "Too many arguments.")))
					   '())
				     (let ()
				       ,@BODY))))))
	      (set-procedure-property! ,lambda-gensym 'arglist
				       '(,non-optional-args
					 ,optionals
					 ,keys
					 ,aok?
					 ,rest-arg))
	      ,lambda-gensym)
	   `(lambda (,@non-optional-args . ,(if rest-arg rest-arg '()))
	      ,@BODY))))))

(define (every? pred lst)
  (or (null? lst)
      (and (pred (car lst))
	   (every? pred (cdr lst)))))

(define (ext-decl? obj)
  (or (symbol? obj)
      (and (list? obj) (= 2 (length obj)) (symbol? (car obj)))))

;; XXX - not tail recursive
(define (improper-list-copy obj)
  (if (pair? obj)
      (cons (car obj) (improper-list-copy (cdr obj)))
      obj))

(define (parse-arglist arglist cont)
  (define (split-list-at val lst cont)
    (cond
     ((memq val lst)
      => (lambda (pos)
	   (if (memq val (cdr pos))
	       (error (with-output-to-string
			(lambda ()
			  (map display `(,val
					 " specified more than once in argument list.")))))
	       (cont (reverse (cdr (memq val (reverse lst)))) (cdr pos) #t))))
     (else (cont lst '() #f))))
  (define (parse-opt-and-fixed arglist keys aok? rest cont)
    (split-list-at
     #:optional arglist
     (lambda (before after split?)
       (if (and split? (null? after))
	   (error "#:optional specified but no optional arguments declared.")
	   (cont before after keys aok? rest)))))
  (define (parse-keys arglist rest cont)
    (split-list-at
     #:allow-other-keys arglist
     (lambda (aok-before aok-after aok-split?)
       (if (and aok-split? (not (null? aok-after)))
	   (error "#:allow-other-keys not at end of keyword argument declarations.")
	   (split-list-at
	    #:key aok-before
	    (lambda (key-before key-after key-split?)
	      (cond
	       ((and aok-split? (not key-split?))
		(error "#:allow-other-keys specified but no keyword arguments declared."))
	       (key-split?
		(cond
		 ((null? key-after) (error "#:key specified but no keyword arguments declared."))
		 ((memq #:optional key-after) (error "#:optional arguments declared after #:key arguments."))
		 (else (parse-opt-and-fixed key-before key-after aok-split? rest cont))))
	       (else (parse-opt-and-fixed arglist '() #f rest cont)))))))))
  (define (parse-rest arglist cont)
    (cond
     ((null? arglist) (cont '() '() '() #f #f))
     ((not (pair? arglist)) (cont '() '() '() #f arglist))
     ((not (list? arglist))
	  (let* ((copy (improper-list-copy arglist))
		 (lp (last-pair copy))
		 (ra (cdr lp)))
	    (set-cdr! lp '())
	    (if (memq #:rest copy)
		(error "Cannot specify both #:rest and dotted rest argument.")
		(parse-keys copy ra cont))))
     (else (split-list-at
	    #:rest arglist
	    (lambda (before after split?)
	      (if split?
		  (case (length after)
		    ((0) (error "#:rest not followed by argument."))
		    ((1) (parse-keys before (car after) cont))
		    (else (error "#:rest argument must be declared last.")))
		  (parse-keys before #f cont)))))))

  (parse-rest arglist cont))

;; define* args . body
;; define*-public args . body
;;   define and define-public extended for optional and keyword arguments
;;
;; define* and define*-public support optional arguments with
;; a similar syntax to lambda*. They also support arbitrary-depth
;; currying, just like Guile's define. Some examples:
;;   (define* (x y #:optional a (z 3) #:key w . u) (display (list y z u)))
;; defines a procedure x with a fixed argument y, an optional agument
;; a, another optional argument z with default value 3, a keyword argument w,
;; and a rest argument u.
;;   (define-public* ((foo #:optional bar) #:optional baz) '())
;; This illustrates currying. A procedure foo is defined, which,
;; when called with an optional argument bar, returns a procedure that
;; takes an optional argument baz.
;;
;; Of course, define*[-public] also supports #:rest and #:allow-other-keys
;; in the same way as lambda*.

(defmacro define* (ARGLIST . BODY)
  (define*-guts 'define ARGLIST BODY))

(defmacro define*-public (ARGLIST . BODY)
  (define*-guts 'define-public ARGLIST BODY))

;; The guts of define* and define*-public.
(define (define*-guts DT ARGLIST BODY)
  (define (nest-lambda*s arglists)
    (if (null? arglists)
        BODY
        `((lambda* ,(car arglists) ,@(nest-lambda*s (cdr arglists))))))
  (define (define*-guts-helper ARGLIST arglists)
    (let ((first (car ARGLIST))
	  (al (cons (cdr ARGLIST) arglists)))
      (if (symbol? first)
	  `(,DT ,first ,@(nest-lambda*s al))
	  (define*-guts-helper first al))))
  (if (symbol? ARGLIST)
      `(,DT ,ARGLIST ,@BODY)
      (define*-guts-helper ARGLIST '())))

;; defmacro* name args . body
;; defmacro*-public args . body
;;   defmacro and defmacro-public extended for optional and keyword arguments
;;
;; These are just like defmacro and defmacro-public except that they
;; take lambda*-style extended paramter lists, where #:optional,
;; #:key, #:allow-other-keys and #:rest are allowed with the usual
;; semantics. Here is an example of a macro with an optional argument:
;;   (defmacro* transmorgify (a #:optional b)

(defmacro defmacro* (NAME ARGLIST . BODY)
  (defmacro*-guts 'define NAME ARGLIST BODY))

(defmacro defmacro*-public (NAME ARGLIST . BODY)
  (defmacro*-guts 'define-public NAME ARGLIST BODY))

;; The guts of defmacro* and defmacro*-public
(define (defmacro*-guts DT NAME ARGLIST BODY)
  `(,DT ,NAME
	(,(lambda (transformer) (defmacro:transformer transformer))
	 (lambda* ,ARGLIST ,@BODY))))

;;; optargs.scm ends here


code:
;;; installed-scm-file

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

(define-module  (ice-9 poe)
  :use-module (ice-9 hcons)
  :export (pure-funcq perfect-funcq))

;;; {Pure Functions}
;;;
;;; A pure function (of some sort) is characterized by two equality
;;; relations: one on argument lists and one on return values.
;;; A pure function is one that when applied to equal arguments lists
;;; yields equal results.
;;;
;;; If the equality relationship on return values can be eq?, it may make
;;; sense to cache values returned by the function.  Choosing the right
;;; equality relation on arguments is tricky.
;;;

;;; {pure-funcq}
;;;
;;; The simplest case of pure functions are those in which results
;;; are only certainly eq? if all of the arguments are.  These functions
;;; are called "pure-funcq", for obvious reasons.
;;;

(define funcq-memo (make-weak-key-hash-table 523)) ; !!! randomly selected values
(define funcq-buffer (make-gc-buffer 256))

(define (funcq-hash arg-list n)
  (let ((it (let loop ((x 0)
		       (arg-list arg-list))
	      (if (null? arg-list)
		  (modulo x n)
		  (loop (logior x (hashq (car arg-list) 4194303))
			(cdr arg-list))))))
    it))

;; return true if lists X and Y are the same length and each element is `eq?'
(define (eq?-list x y)
  (if (null? x)
      (null? y)
      (and (not (null? y))
	   (eq? (car x) (car y))
	   (eq?-list (cdr x) (cdr y)))))

(define (funcq-assoc arg-list alist)
  (if (null? alist)
      #f
      (if (eq?-list arg-list (caar alist))
	  (car alist)
	  (funcq-assoc arg-list (cdr alist)))))

(define (pure-funcq base-func)
  (lambda args
    (let ((cached (hashx-get-handle funcq-hash funcq-assoc funcq-memo (cons base-func args))))
      (if cached
	  (begin
	    (funcq-buffer (car cached))
	    (cdr cached))

	  (let ((val (apply base-func args))
		(key (cons base-func args)))
	    (funcq-buffer key)
	    (hashx-set! funcq-hash funcq-assoc funcq-memo key val)
	    val)))))

;;; {Perfect funq}
;;;
;;; A pure funq may sometimes forget its past but a perfect
;;; funcq never does.
;;;

(define (perfect-funcq size base-func)
  (define funcq-memo (make-hash-table size))

  (lambda args
    (let ((cached (hashx-get-handle funcq-hash funcq-assoc funcq-memo (cons base-func args))))
      (if cached
	  (begin
	    (funcq-buffer (car cached))
	    (cdr cached))

	  (let ((val (apply base-func args))
		(key (cons base-func args)))
	    (funcq-buffer key)
	    (hashx-set! funcq-hash funcq-assoc funcq-memo key val)
	    val)))))