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

(use-modules (ice-9 debugger utils))

(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
      (let ((gds-unix-socket-name (getenv "GDS_UNIX_SOCKET_NAME")))
        (set! gds-port
	      (or (and gds-unix-socket-name
		       (false-if-exception
			(let ((s (socket PF_UNIX SOCK_STREAM 0)))
			  (connect s AF_UNIX gds-unix-socket-name)
			  s)))
		  (false-if-exception
		   (let ((s (socket PF_INET SOCK_STREAM 0))
			 (SOL_TCP 6)
			 (TCP_NODELAY 1))
		     (setsockopt s SOL_TCP TCP_NODELAY 1)
		     (connect s AF_INET (inet-aton "127.0.0.1") 8333)
		     s))
		  (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)))

;; FIXME: the new evaluator breaks this, by removing local-eval. Need to
;; figure out our story in this regard.
(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)
  (module-use! (resolve-module '(guile-user))
               (resolve-interface '(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 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (ice-9 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 unix-socket-name tcp-port)

  (let ((unix-server (socket PF_UNIX SOCK_STREAM 0))
	(tcp-server (socket PF_INET SOCK_STREAM 0)))

    ;; Bind and start listening on the Unix domain socket.
    (false-if-exception (delete-file unix-socket-name))
    (bind unix-server AF_UNIX unix-socket-name)
    (listen unix-server 5)

    ;; Bind and start listening on the TCP socket.
    (setsockopt tcp-server SOL_SOCKET SO_REUSEADDR 1)
    (false-if-exception (bind tcp-server AF_INET INADDR_ANY tcp-port))
    (listen tcp-server 5)

    ;; Main loop.
    (let loop ((clients '()) (readable-sockets '()))

      (define (do-read port)
	(cond ((eq? port (current-input-port))
	       (do-read-from-ui))
	      ((eq? port unix-server)
	       (accept-new-client unix-server))
	      ((eq? port tcp-server)
	       (accept-new-client tcp-server))
	      (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 server)
        (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)
					    unix-server
					    tcp-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: mit


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

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

(eval-when (eval load compile)
  ;; This binding is used both at compile-time and run-time.
  (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))

(eval-when (eval load compile)
  ;; The following procedures are used only at compile-time when expanding
  ;; `define-all-option-spec-accessors/modifiers' (see below).

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

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

;;;; A simple value history support

(define-module (ice-9 history)
  #:export (value-history-enabled? enable-value-history! disable-value-history!
            clear-value-history!))

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

(define *value-history-enabled?* #f)
(define (value-history-enabled?)
  *value-history-enabled?*)

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

(define (enable-value-history!)
  (if (not (value-history-enabled?))
      (begin
        (add-hook! before-eval-hook use-value-history)
        (add-hook! before-print-hook save-value-history)
        (set! *value-history-enabled?* #t))))

(define (disable-value-history!)
  (if (value-history-enabled?)
      (begin
        (remove-hook! before-eval-hook use-value-history)
        (remove-hook! before-print-hook save-value-history)
        (set! *value-history-enabled?* #f))))

(define (clear-value-history!)
  (let ((history (resolve-module '(value-history))))
    (hash-clear! (module-obarray history))
    (hash-clear! (module-obarray (module-public-interface history)))))

(enable-value-history!)


code:
;;;; i18n.scm --- internationalization support    -*- coding: utf-8 -*-

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

;;; Author: Ludovic Courtès <ludo@gnu.org>

;;; Commentary:
;;;
;;; This module provides a number of routines that support
;;; internationalization (e.g., locale-dependent text collation, character
;;; mapping, etc.).  It also defines `locale' objects, representing locale
;;; settings, that may be passed around to most of these procedures.
;;;

;;; Code:

(define-module (ice-9 i18n)
  :use-module (ice-9 optargs)
  :export (;; `locale' type
           make-locale locale?
           %global-locale

           ;; text collation
           string-locale<? string-locale>?
           string-locale-ci<? string-locale-ci>? string-locale-ci=?

           char-locale<? char-locale>?
           char-locale-ci<? char-locale-ci>? char-locale-ci=?

           ;; character mapping
           char-locale-downcase char-locale-upcase char-locale-titlecase
           string-locale-downcase string-locale-upcase string-locale-titlecase

           ;; reading numbers
           locale-string->integer locale-string->inexact

           ;; charset/encoding
           locale-encoding

           ;; days and months
           locale-day-short locale-day locale-month-short locale-month

           ;; date and time
           locale-am-string locale-pm-string
           locale-date+time-format locale-date-format locale-time-format
           locale-time+am/pm-format
           locale-era locale-era-year
           locale-era-date-format locale-era-date+time-format
           locale-era-time-format

           ;; monetary
           locale-currency-symbol
           locale-monetary-decimal-point locale-monetary-thousands-separator
           locale-monetary-grouping locale-monetary-fractional-digits
           locale-currency-symbol-precedes-positive?
           locale-currency-symbol-precedes-negative?
           locale-positive-separated-by-space?
           locale-negative-separated-by-space?
           locale-monetary-positive-sign locale-monetary-negative-sign
           locale-positive-sign-position locale-negative-sign-position
           monetary-amount->locale-string

           ;; number formatting
           locale-digit-grouping locale-decimal-point
           locale-thousands-separator
           number->locale-string

           ;; miscellaneous
           locale-yes-regexp locale-no-regexp))

(eval-when (eval load compile)
  (load-extension (string-append "libguile-" (effective-version))
                  "scm_init_i18n"))

;;;
;;; Charset/encoding.
;;;

(define (locale-encoding . locale)
  (apply nl-langinfo CODESET locale))

;;;
;;; Months and days.
;;;

;; Helper macro: Define a procedure named NAME that maps its argument to
;; NL-ITEMS (when `nl-langinfo' is provided) or DEFAULTS (when `nl-langinfo'
;; is not provided).
(define-macro (define-vector-langinfo-mapping name nl-items defaults)
  (let* ((item-count (length nl-items))
         (defines    (if (provided? 'nl-langinfo)
                         `(define %nl-items (vector #f ,@nl-items))
                         `(define %defaults (vector #f ,@defaults))))
         (make-body (lambda (result)
                      `(if (and (integer? item) (exact? item))
                           (if (and (>= item 1) (<= item ,item-count))
                               ,result
                               (throw 'out-of-range "out of range" item))
                           (throw 'wrong-type-arg "wrong argument type" item)))))
    `(define (,name item . locale)
       ,defines
       ,(make-body (if (provided? 'nl-langinfo)
                       '(apply nl-langinfo (vector-ref %nl-items item) locale)
                       '(vector-ref %defaults item))))))

(define-vector-langinfo-mapping locale-day-short
  (ABDAY_1 ABDAY_2 ABDAY_3 ABDAY_4 ABDAY_5 ABDAY_6 ABDAY_7)
  ("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))

(define-vector-langinfo-mapping locale-day
  (DAY_1 DAY_2 DAY_3 DAY_4 DAY_5 DAY_6 DAY_7)
  ("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))

(define-vector-langinfo-mapping locale-month-short
  (ABMON_1 ABMON_2 ABMON_3 ABMON_4 ABMON_5 ABMON_6
   ABMON_7 ABMON_8 ABMON_9 ABMON_10 ABMON_11 ABMON_12)
  ("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))

(define-vector-langinfo-mapping locale-month
  (MON_1 MON_2 MON_3 MON_4 MON_5 MON_6 MON_7 MON_8 MON_9 MON_10 MON_11 MON_12)
  ("January" "February" "March" "April" "May" "June" "July" "August"
   "September" "October" "November" "December"))

;;;
;;; Date and time.
;;;

;; Helper macro: Define a procedure NAME that gets langinfo item ITEM.
(define-macro (define-simple-langinfo-mapping name item default)
  (let ((body (if (and (provided? 'nl-langinfo) (defined? item))
                  `(apply nl-langinfo ,item locale)
                  default)))
    `(define (,name . locale)
       ,body)))

(define-simple-langinfo-mapping locale-am-string
  AM_STR "AM")
(define-simple-langinfo-mapping locale-pm-string
  PM_STR "PM")
(define-simple-langinfo-mapping locale-date+time-format
  D_T_FMT "%a %b %e %H:%M:%S %Y")
(define-simple-langinfo-mapping locale-date-format
  D_FMT   "%m/%d/%y")
(define-simple-langinfo-mapping locale-time-format
  T_FMT   "%H:%M:%S")
(define-simple-langinfo-mapping locale-time+am/pm-format
  T_FMT_AMPM "%I:%M:%S %p")
(define-simple-langinfo-mapping locale-era
  ERA        "")
(define-simple-langinfo-mapping locale-era-year
  ERA_YEAR   "")
(define-simple-langinfo-mapping locale-era-date+time-format
  ERA_D_T_FMT "")
(define-simple-langinfo-mapping locale-era-date-format
  ERA_D_FMT   "")
(define-simple-langinfo-mapping locale-era-time-format
  ERA_T_FMT   "")

;;;
;;; Monetary information.
;;;

(define-macro (define-monetary-langinfo-mapping name local-item intl-item
                                                default/local default/intl)
  (let ((body
         (let ((intl  (if (and (provided? 'nl-langinfo) (defined? intl-item))
                          `(apply nl-langinfo ,intl-item locale)
                          default/intl))
               (local (if (and (provided? 'nl-langinfo) (defined? local-item))
                          `(apply nl-langinfo ,local-item locale)
                          default/local)))
           `(if intl? ,intl ,local))))

    `(define (,name intl? . locale)
       ,body)))

;; FIXME: How can we use ALT_DIGITS?
(define-monetary-langinfo-mapping locale-currency-symbol
  CRNCYSTR           INT_CURR_SYMBOL
  "-"                "")
(define-monetary-langinfo-mapping locale-monetary-fractional-digits
  FRAC_DIGITS        INT_FRAC_DIGITS
  2                  2)

(define-simple-langinfo-mapping locale-monetary-positive-sign
  POSITIVE_SIGN        "+")
(define-simple-langinfo-mapping locale-monetary-negative-sign
  NEGATIVE_SIGN        "-")
(define-simple-langinfo-mapping locale-monetary-decimal-point
  MON_DECIMAL_POINT    "")
(define-simple-langinfo-mapping locale-monetary-thousands-separator
  MON_THOUSANDS_SEP    "")
(define-simple-langinfo-mapping locale-monetary-digit-grouping
  MON_GROUPING         '())

(define-monetary-langinfo-mapping locale-currency-symbol-precedes-positive?
  P_CS_PRECEDES       INT_P_CS_PRECEDES
  #t                  #t)
(define-monetary-langinfo-mapping locale-currency-symbol-precedes-negative?
  N_CS_PRECEDES       INT_N_CS_PRECEDES
  #t                  #t)

(define-monetary-langinfo-mapping locale-positive-separated-by-space?
  ;; Whether a space should be inserted between a positive amount and the
  ;; currency symbol.
  P_SEP_BY_SPACE      INT_P_SEP_BY_SPACE
  #t                  #t)
(define-monetary-langinfo-mapping locale-negative-separated-by-space?
  ;; Whether a space should be inserted between a negative amount and the
  ;; currency symbol.
  N_SEP_BY_SPACE      INT_N_SEP_BY_SPACE
  #t                  #t)

(define-monetary-langinfo-mapping locale-positive-sign-position
  ;; Position of the positive sign wrt. currency symbol and quantity in a
  ;; monetary amount.
  P_SIGN_POSN         INT_P_SIGN_POSN
  'unspecified        'unspecified)
(define-monetary-langinfo-mapping locale-negative-sign-position
  ;; Position of the negative sign wrt. currency symbol and quantity in a
  ;; monetary amount.
  N_SIGN_POSN         INT_N_SIGN_POSN
  'unspecified        'unspecified)

(define (%number-integer-part int grouping separator)
  ;; Process INT (a string denoting a number's integer part) and return a new
  ;; string with digit grouping and separators according to GROUPING (a list,
  ;; potentially circular) and SEPARATOR (a string).

  ;; Process INT from right to left.
  (let loop ((int      int)
             (grouping grouping)
             (result   '()))
    (cond ((string=? int "") (apply string-append result))
          ((null? grouping)  (apply string-append int result))
          (else
           (let* ((len (string-length int))
                  (cut (min (car grouping) len)))
             (loop (substring int 0 (- len cut))
                   (cdr grouping)
                   (let ((sub (substring int (- len cut) len)))
                     (if (> len cut)
                         (cons* separator sub result)
                         (cons sub result)))))))))

(define (add-monetary-sign+currency amount figure intl? locale)
  ;; Add a sign and currency symbol around FIGURE.  FIGURE should be a
  ;; formatted unsigned amount (a string) representing AMOUNT.
  (let* ((positive? (> amount 0))
         (sign
          (cond ((> amount 0) (locale-monetary-positive-sign locale))
                ((< amount 0) (locale-monetary-negative-sign locale))
                (else         "")))
         (currency (locale-currency-symbol intl? locale))
         (currency-precedes?
          (if positive?
              locale-currency-symbol-precedes-positive?
              locale-currency-symbol-precedes-negative?))
         (separated?
          (if positive?
              locale-positive-separated-by-space?
              locale-negative-separated-by-space?))
         (sign-position
          (if positive?
              locale-positive-sign-position
              locale-negative-sign-position))
         (currency-space
          (if (separated? intl? locale) " " ""))
         (append-currency
          (lambda (amt)
            (if (currency-precedes? intl? locale)
                (string-append currency currency-space amt)
                (string-append amt currency-space currency)))))

    (case (sign-position intl? locale)
      ((parenthesize)
       (string-append "(" (append-currency figure) ")"))
      ((sign-before)
       (string-append sign (append-currency figure)))
      ((sign-after unspecified)
       ;; following glibc's recommendation for `unspecified'.
       (if (currency-precedes? intl? locale)
           (string-append currency currency-space sign figure)
           (string-append figure currency-space currency sign)))
      ((sign-before-currency-symbol)
       (if (currency-precedes? intl? locale)
           (string-append sign currency currency-space figure)
           (string-append figure currency-space sign currency))) ;; unlikely
      ((sign-after-currency-symbol)
       (if (currency-precedes? intl? locale)
           (string-append currency sign currency-space figure)
           (string-append figure currency-space currency sign)))
      (else
       (error "unsupported sign position" (sign-position intl? locale))))))

(define* (monetary-amount->locale-string amount intl?
                                         #:optional (locale %global-locale))
  "Convert @var{amount} (an inexact) into a string according to the cultural
conventions of either @var{locale} (a locale object) or the current locale.
If @var{intl?} is true, then the international monetary format for the given
locale is used."

  (let* ((fraction-digits
          (or (locale-monetary-fractional-digits intl? locale) 2))
         (decimal-part
          (lambda (dec)
            (if (or (string=? dec "") (eq? 0 fraction-digits))
                ""
                (string-append (locale-monetary-decimal-point locale)
                               (if (< fraction-digits (string-length dec))
                                   (substring dec 0 fraction-digits)
                                   dec)))))

         (external-repr (number->string (if (> amount 0) amount (- amount))))
         (int+dec   (string-split external-repr #\.))
         (int       (car int+dec))
         (dec       (decimal-part (if (null? (cdr int+dec))
                                      ""
                                      (cadr int+dec))))
         (grouping  (locale-monetary-digit-grouping locale))
         (separator (locale-monetary-thousands-separator locale)))

      (add-monetary-sign+currency amount
                                  (string-append
                                   (%number-integer-part int grouping
                                                         separator)
                                   dec)
                                  intl? locale)))

;;;
;;; Number formatting.
;;;

(define-simple-langinfo-mapping locale-digit-grouping
  GROUPING             '())
(define-simple-langinfo-mapping locale-decimal-point
  RADIXCHAR            ".")
(define-simple-langinfo-mapping locale-thousands-separator
  THOUSEP              "")

(define* (number->locale-string number
                                #:optional (fraction-digits #t)
                                           (locale %global-locale))
  "Convert @var{number} (an inexact) into a string according to the cultural
conventions of either @var{locale} (a locale object) or the current locale.
Optionally, @var{fraction-digits} may be bound to an integer specifying the
number of fractional digits to be displayed."

  (let* ((sign
          (cond ((> number 0) "")
                ((< number 0) "-")
                (else         "")))
         (decimal-part
          (lambda (dec)
            (if (or (string=? dec "") (eq? 0 fraction-digits))
                ""
                (string-append (locale-decimal-point locale)
                               (if (and (integer? fraction-digits)
                                        (< fraction-digits
                                           (string-length dec)))
                                   (substring dec 0 fraction-digits)
                                   dec))))))

    (let* ((external-repr (number->string (if (> number 0)
                                              number
                                              (- number))))
           (int+dec   (string-split external-repr #\.))
           (int       (car int+dec))
           (dec       (decimal-part (if (null? (cdr int+dec))
                                        ""
                                        (cadr int+dec))))
           (grouping  (locale-digit-grouping locale))
           (separator (locale-thousands-separator locale)))

      (string-append sign
                     (%number-integer-part int grouping separator)
                     dec))))

;;;
;;; Miscellaneous.
;;;

(define-simple-langinfo-mapping locale-yes-regexp
  YESEXPR              "^[yY]")
(define-simple-langinfo-mapping locale-no-regexp
  NOEXPR               "^[nN]")

;; `YESSTR' and `NOSTR' are considered deprecated so we don't provide them.

;;; i18n.scm ends here


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

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

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

(define-module (ice-9 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-module root names)))
    (if m
        (module-map (lambda (k v) k) m)
        (nested-ref root names))))

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

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

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

(define-module (ice-9 match)
  #:export (match
            match-lambda
            match-lambda*
            match-let
            match-let*
            match-letrec))

(define (error _ msg)
  ;; Error procedure for run-time "no matching pattern" errors.
  (throw 'match-error "match" msg))

;; Compared to Andrew K. Wright's `match', this one lacks `match-define',
;; `match:error-control', `match:set-error-control', `match:error',
;; `match:set-error', and all structure-related procedures.

;; Unmodified public domain code by Alex Shinn retrieved from
;; <http://synthcode.com/scheme/match.scm>.
(include-from-path "ice-9/match.upstream.scm")