code:
;;; installed-scm-file

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

;;; This is the Scheme part of the module for delimited I/O.  It's
;;; similar to (scsh rdelim) but somewhat incompatible.

(define-module (ice-9 rdelim)
  :export (read-line read-line! read-delimited read-delimited!
	   %read-delimited! %read-line write-line)  ; C
  )

(%init-rdelim-builtins)

(define (read-line! string . maybe-port)
  ;; corresponds to SCM_LINE_INCREMENTORS in libguile.
  (define scm-line-incrementors "\n")

  (let* ((port (if (pair? maybe-port)
		   (car maybe-port)
		   (current-input-port))))
    (let* ((rv (%read-delimited! scm-line-incrementors
				 string
				 #t
				 port))
	   (terminator (car rv))
	   (nchars (cdr rv)))
      (cond ((and (= nchars 0)
		  (eof-object? terminator))
	     terminator)
	    ((not terminator) #f)
	    (else nchars)))))

(define (read-delimited! delims buf . args)
  (let* ((num-args (length args))
	 (port (if (> num-args 0)
		   (car args)
		   (current-input-port)))
	 (handle-delim (if (> num-args 1)
			   (cadr args)
			   'trim))
	 (start (if (> num-args 2)
		    (caddr args)
		    0))
	 (end (if (> num-args 3)
		  (cadddr args)
		  (string-length buf))))
    (let* ((rv (%read-delimited! delims
				 buf
				 (not (eq? handle-delim 'peek))
				 port
				 start
				 end))
	   (terminator (car rv))
	   (nchars (cdr rv)))
      (cond ((or (not terminator)	; buffer filled
		 (eof-object? terminator))
	     (if (zero? nchars)
		 (if (eq? handle-delim 'split)
		     (cons terminator terminator)
		     terminator)
		 (if (eq? handle-delim 'split)
		     (cons nchars terminator)
		     nchars)))
	    (else
	     (case handle-delim
	       ((trim peek) nchars)
	       ((concat) (string-set! buf (+ nchars start) terminator)
			 (+ nchars 1))
	       ((split) (cons nchars terminator))
	       (else (error "unexpected handle-delim value: "
			    handle-delim))))))))

(define (read-delimited delims . args)
  (let* ((port (if (pair? args)
		   (let ((pt (car args)))
		     (set! args (cdr args))
		     pt)
		   (current-input-port)))
	 (handle-delim (if (pair? args)
			   (car args)
			   'trim)))
    (let loop ((substrings '())
	       (total-chars 0)
	       (buf-size 100))		; doubled each time through.
      (let* ((buf (make-string buf-size))
	     (rv (%read-delimited! delims
				   buf
				   (not (eq? handle-delim 'peek))
				   port))
	     (terminator (car rv))
	     (nchars (cdr rv))
	     (join-substrings
	      (lambda ()
		(apply string-append
		       (reverse
			(cons (if (and (eq? handle-delim 'concat)
				       (not (eof-object? terminator)))
				  (string terminator)
				  "")
			      (cons (substring buf 0 nchars)
				    substrings))))))
	     (new-total (+ total-chars nchars)))
	(cond ((not terminator)
	       ;; buffer filled.
	       (loop (cons (substring buf 0 nchars) substrings)
		     new-total
		     (* buf-size 2)))
	      ((eof-object? terminator)
	       (if (zero? new-total)
		   (if (eq? handle-delim 'split)
		       (cons terminator terminator)
		       terminator)
		   (if (eq? handle-delim 'split)
		       (cons (join-substrings) terminator)
		       (join-substrings))))
	      (else
	       (case handle-delim
		   ((trim peek concat) (join-substrings))
		   ((split) (cons (join-substrings) terminator))

		   (else (error "unexpected handle-delim value: "
				handle-delim)))))))))

;;; read-line [PORT [HANDLE-DELIM]] reads a newline-terminated string
;;; from PORT.  The return value depends on the value of HANDLE-DELIM,
;;; which may be one of the symbols `trim', `concat', `peek' and
;;; `split'.  If it is `trim' (the default), the trailing newline is
;;; removed and the string is returned.  If `concat', the string is
;;; returned with the trailing newline intact.  If `peek', the newline
;;; is left in the input port buffer and the string is returned.  If
;;; `split', the newline is split from the string and read-line
;;; returns a pair consisting of the truncated string and the newline.

(define (read-line . args)
  (let* ((port		(if (null? args)
			    (current-input-port)
			    (car args)))
	 (handle-delim	(if (> (length args) 1)
			    (cadr args)
			    'trim))
	 (line/delim	(%read-line port))
	 (line		(car line/delim))
	 (delim		(cdr line/delim)))
    (case handle-delim
      ((trim) line)
      ((split) line/delim)
      ((concat) (if (and (string? line) (char? delim))
		    (string-append line (string delim))
		    line))
      ((peek) (if (char? delim)
		  (unread-char delim port))
	      line)
      (else
       (error "unexpected handle-delim value: " handle-delim)))))


code:
;;;; SRFI-8

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

(define-module (ice-9 receive)
  :export (receive)
  :no-backtrace
  )

(define-macro (receive vars vals . body)
  `(call-with-values (lambda () ,vals)
     (lambda ,vars ,@body)))

(cond-expand-provide (current-module) '(srfi-8))

license: unknown


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

;;; Commentary:

;; These procedures are exported:
;;  (match:count match)
;;  (match:string match)
;;  (match:prefix match)
;;  (match:suffix match)
;;  (regexp-match? match)
;;  (regexp-quote string)
;;  (match:start match . submatch-num)
;;  (match:end match . submatch-num)
;;  (match:substring match . submatch-num)
;;  (string-match pattern str . start)
;;  (regexp-substitute port match . items)
;;  (fold-matches regexp string init proc . flags)
;;  (list-matches regexp string . flags)
;;  (regexp-substitute/global port regexp string . items)

;;; Code:

;;;; POSIX regex support functions.

(define-module (ice-9 regex)
  :export (match:count match:string match:prefix match:suffix
	   regexp-match? regexp-quote match:start match:end match:substring
	   string-match regexp-substitute fold-matches list-matches
	   regexp-substitute/global))

;; References:
;;
;; POSIX spec:
;; http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap09.html

;;; FIXME:
;;;   It is not clear what should happen if a `match' function
;;;   is passed a `match number' which is out of bounds for the
;;;   regexp match: return #f, or throw an error?  These routines
;;;   throw an out-of-range error.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; These procedures are not defined in SCSH, but I found them useful.

(define (match:count match)
  (- (vector-length match) 1))

(define (match:string match)
  (vector-ref match 0))

(define (match:prefix match)
  (substring (match:string match) 0 (match:start match 0)))

(define (match:suffix match)
  (substring (match:string match) (match:end match 0)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; SCSH compatibility routines.

(define (regexp-match? match)
  (and (vector? match)
       (string? (vector-ref match 0))
       (let loop ((i 1))
	 (cond ((>= i (vector-length match)) #t)
	       ((and (pair? (vector-ref match i))
		     (integer? (car (vector-ref match i)))
		     (integer? (cdr (vector-ref match i))))
		(loop (+ 1 i)))
	       (else #f)))))

;; * . \ ^ $ and [ are special in both regexp/basic and regexp/extended and
;; can be backslash escaped.
;;
;; ( ) + ? { } and | are special in regexp/extended so must be quoted.  But
;; that can't be done with a backslash since in regexp/basic where they're
;; not special, adding a backslash makes them become special.  Character
;; class forms [(] etc are used instead.
;;
;; ) is not special when not preceded by a (, and * and ? are not special at
;; the start of a string, but we quote all of these always, so the result
;; can be concatenated or merged into some larger regexp.
;;
;; ] is not special outside a [ ] character class, so doesn't need to be
;; quoted.
;;
(define (regexp-quote string)
  (call-with-output-string
   (lambda (p)
     (string-for-each (lambda (c)
			(case c
			  ((#\* #\. #\\ #\^ #\$ #\[)
			   (write-char #\\ p)
			   (write-char c p))
			  ((#\( #\) #\+ #\? #\{ #\} #\|)
			   (write-char #\[ p)
			   (write-char c p)
			   (write-char #\] p))
			  (else
			   (write-char c p))))
		      string))))

(define (match:start match . args)
  (let* ((matchnum (if (pair? args)
		       (+ 1 (car args))
		       1))
	 (start (car (vector-ref match matchnum))))
    (if (= start -1) #f start)))

(define (match:end match . args)
  (let* ((matchnum (if (pair? args)
		       (+ 1 (car args))
		       1))
	 (end (cdr (vector-ref match matchnum))))
    (if (= end -1) #f end)))

(define (match:substring match . args)
  (let* ((matchnum (if (pair? args)
		       (car args)
		       0))
	 (start (match:start match matchnum))
	 (end   (match:end match matchnum)))
    (and start end (substring (match:string match) start end))))

(define (string-match pattern str . args)
  (let ((rx (make-regexp pattern))
	(start (if (pair? args) (car args) 0)))
    (regexp-exec rx str start)))

(define (regexp-substitute port match . items)
  ;; If `port' is #f, send output to a string.
  (if (not port)
      (call-with-output-string
       (lambda (p)
	 (apply regexp-substitute p match items)))

      ;; Otherwise, process each substitution argument in `items'.
      (for-each (lambda (obj)
		  (cond ((string? obj)   (display obj port))
			((integer? obj)  (display (match:substring match obj) port))
			((eq? 'pre obj)  (display (match:prefix match) port))
			((eq? 'post obj) (display (match:suffix match) port))
			(else (error 'wrong-type-arg obj))))
		items)))

;;; If we call fold-matches, below, with a regexp that can match the
;;; empty string, it's not obvious what "all the matches" means.  How
;;; many empty strings are there in the string "a"?  Our answer:
;;;
;;; 	This function applies PROC to every non-overlapping, maximal
;;;     match of REGEXP in STRING.
;;;
;;; "non-overlapping": There are two non-overlapping matches of "" in
;;; "a" --- one before the `a', and one after.  There are three
;;; non-overlapping matches of "q|x*" in "aqb": the empty strings
;;; before `a' and after `b', and `q'.  The two empty strings before
;;; and after `q' don't count, because they overlap with the match of
;;; "q".
;;;
;;; "maximal": There are three distinct maximal matches of "x*" in
;;; "axxxb": one before the `a', one covering `xxx', and one after the
;;; `b'.  Around or within `xxx', only the match covering all three
;;; x's counts, because the rest are not maximal.

(define (fold-matches regexp string init proc . flags)
  (let ((regexp (if (regexp? regexp) regexp (make-regexp regexp)))
	(flags (if (null? flags) 0 (car flags))))
    (let loop ((start 0)
	       (value init)
	       (abuts #f))		; True if start abuts a previous match.
      (let ((m (if (> start (string-length string)) #f
		   (regexp-exec regexp string start flags))))
	(cond
	 ((not m) value)
	 ((and (= (match:start m) (match:end m)) abuts)
	  ;; We matched an empty string, but that would overlap the
	  ;; match immediately before.  Try again at a position
	  ;; further to the right.
	  (loop (+ start 1) value #f))
	 (else
	  (loop (match:end m) (proc m value) #t)))))))

(define (list-matches regexp string . flags)
  (reverse! (apply fold-matches regexp string '() cons flags)))

(define (regexp-substitute/global port regexp string . items)

  ;; If `port' is #f, send output to a string.
  (if (not port)
      (call-with-output-string
       (lambda (p)
	 (apply regexp-substitute/global p regexp string items)))

      ;; Walk the set of non-overlapping, maximal matches.
      (let next-match ((matches (list-matches regexp string))
		       (start 0))
	(if (null? matches)
	    (display (substring string start) port)
	    (let ((m (car matches)))

	      ;; Process all of the items for this match.  Don't use
	      ;; for-each, because we need to make sure 'post at the
	      ;; end of the item list is a tail call.
	      (let next-item ((items items))

		(define (do-item item)
		  (cond
		   ((string? item)    (display item port))
		   ((integer? item)   (display (match:substring m item) port))
		   ((procedure? item) (display (item m) port))
		   ((eq? item 'pre)
		    (display
		     (substring string start (match:start m))
		     port))
		   ((eq? item 'post)
		    (next-match (cdr matches) (match:end m)))
		   (else (error 'wrong-type-arg item))))

		(if (pair? items)
		    (if (null? (cdr items))
			(do-item (car items)) ; This is a tail call.
			(begin
			  (do-item (car items)) ; This is not.
			  (next-item (cdr items)))))))))))


code:
;;;; runq.scm --- the runq data structure
;;;;
;;;; 	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
;;;;

;;; Commentary:

;;; One way to schedule parallel computations in a serial environment is
;;; to explicitly divide each task up into small, finite execution time,
;;; strips.  Then you interleave the execution of strips from various
;;; tasks to achieve a kind of parallelism.  Runqs are a handy data
;;; structure for this style of programming.
;;;
;;; We use thunks (nullary procedures) and lists of thunks to represent
;;; strips.  By convention, the return value of a strip-thunk must either
;;; be another strip or the value #f.
;;;
;;; A runq is a procedure that manages a queue of strips.  Called with no
;;; arguments, it processes one strip from the queue.  Called with
;;; arguments, the arguments form a control message for the queue.  The
;;; first argument is a symbol which is the message selector.
;;;
;;; A strip is processed this way: If the strip is a thunk, the thunk is
;;; called -- if it returns a strip, that strip is added back to the
;;; queue.  To process a strip which is a list of thunks, the CAR of that
;;; list is called.  After a call to that CAR, there are 0, 1, or 2 strips
;;; -- perhaps one returned by the thunk, and perhaps the CDR of the
;;; original strip if that CDR is not nil.  The runq puts whichever of
;;; these strips exist back on the queue.  (The exact order in which
;;; strips are put back on the queue determines the scheduling behavior of
;;; a particular queue -- it's a parameter.)

;;; Code:

(define-module (ice-9 runq)
  :use-module (ice-9 q)
  :export (runq-control make-void-runq make-fair-runq
	   make-exclusive-runq make-subordinate-runq-to strip-sequence
	   fair-strip-subtask))

;;;;
;;; 	(runq-control q msg . args)
;;;
;;; 		processes in the default way the control messages that
;;; 		can be sent to a runq.  Q should be an ordinary
;;; 		Q (see utils/q.scm).
;;;
;;; 		The standard runq messages are:
;;;
;;; 		'add! strip0 strip1...		;; to enqueue one or more strips
;;; 		'enqueue! strip0 strip1...	;; to enqueue one or more strips
;;; 		'push! strip0 ...		;; add strips to the front of the queue
;;; 		'empty?				;; true if it is
;;; 		'length				;; how many strips in the queue?
;;; 		'kill!				;; empty the queue
;;; 		else				;; throw 'not-understood
;;;
(define (runq-control q msg . args)
  (case msg
    ((add!)			(for-each (lambda (t) (enq! q t)) args) '*unspecified*)
    ((enqueue!)			(for-each (lambda (t) (enq! q t)) args) '*unspecified*)
    ((push!)			(for-each (lambda (t) (q-push! q t)) args) '*unspecified*)
    ((empty?)			(q-empty? q))
    ((length)			(q-length q))
    ((kill!)			(set! q (make-q)))
    (else			(throw 'not-understood msg args))))

(define (run-strip thunk) (catch #t thunk (lambda ign (warn 'runq-strip thunk ign) #f)))

;;;;
;;; make-void-runq
;;;
;;; Make a runq that discards all messages except "length", for which
;;; it returns 0.
;;;
(define (make-void-runq)
  (lambda opts
    (and opts
	(apply-to-args opts
	  (lambda (msg . args)
	    (case msg
	      ((length)		0)
	      (else		#f)))))))

;;;;
;;; 	(make-fair-runq)
;;;
;;; 		Returns a runq procedure.
;;; 		Called with no arguments, the procedure processes one strip from the queue.
;;; 		Called with arguments, it uses runq-control.
;;;
;;; 		In a fair runq, if a strip returns a new strip X, X is added
;;; 		to the end of the queue, meaning it will be the last to execute
;;; 		of all the remaining procedures.
;;;
(define (make-fair-runq)
  (letrec ((q (make-q))
	   (self
	    (lambda ctl
	      (if ctl
		  (apply runq-control q ctl)
		  (and (not (q-empty? q))
		       (let ((next-strip (deq! q)))
			 (cond
			  ((procedure? next-strip)	(let ((k (run-strip next-strip)))
							  (and k (enq! q k))))
			  ((pair? next-strip) (let ((k (run-strip (car next-strip))))
						(and k (enq! q k)))
					      (if (not (null? (cdr next-strip)))
						  (enq! q (cdr next-strip)))))
			 self))))))
    self))

;;;;
;;; 	(make-exclusive-runq)
;;;
;;; 		Returns a runq procedure.
;;; 		Called with no arguments, the procedure processes one strip from the queue.
;;; 		Called with arguments, it uses runq-control.
;;;
;;; 		In an exclusive runq, if a strip W returns a new strip X, X is added
;;; 		to the front of the queue, meaning it will be the next to execute
;;; 		of all the remaining procedures.
;;;
;;; 		An exception to this occurs if W was the CAR of a list of strips.
;;; 		In that case, after the return value of W is pushed onto the front
;;; 	 	of the queue, the CDR of the list of strips is pushed in front
;;; 		of that (if the CDR is not nil).   This way, the rest of the thunks
;;; 		in the list that contained W have priority over the return value of W.
;;;
(define (make-exclusive-runq)
  (letrec ((q (make-q))
	   (self
	    (lambda ctl
	      (if ctl
		  (apply runq-control q ctl)
		  (and (not (q-empty? q))
		       (let ((next-strip (deq! q)))
			 (cond
			  ((procedure? next-strip)	(let ((k (run-strip next-strip)))
							  (and k (q-push! q k))))
			  ((pair? next-strip) (let ((k (run-strip (car next-strip))))
						(and k (q-push! q k)))
					      (if (not (null? (cdr next-strip)))
						  (q-push! q (cdr next-strip)))))
			 self))))))
    self))

;;;;
;;; 	(make-subordinate-runq-to superior basic-inferior)
;;;
;;; 		Returns a runq proxy for the runq basic-inferior.
;;;
;;; 		The proxy watches for operations on the basic-inferior that cause
;;; 		a transition from a queue length of 0 to a non-zero length and
;;; 		vice versa.   While the basic-inferior queue is not empty,
;;; 		the proxy installs a task on the superior runq.  Each strip
;;; 		of that task processes N strips from the basic-inferior where
;;; 		N is the length of the basic-inferior queue when the proxy
;;; 		strip is entered.  [Countless scheduling variations are possible.]
;;;
(define (make-subordinate-runq-to superior-runq basic-runq)
  (let ((runq-task (cons #f #f)))
    (set-car! runq-task
	      (lambda ()
		(if (basic-runq 'empty?)
		    (set-cdr! runq-task #f)
		    (do ((n (basic-runq 'length) (1- n)))
			((<= n 0)		 #f)
		      (basic-runq)))))
    (letrec ((self
	      (lambda ctl
		(if (not ctl)
		    (let ((answer (basic-runq)))
		      (self 'empty?)
		      answer)
		    (begin
		      (case (car ctl)
			((suspend)		(set-cdr! runq-task #f))
			(else		      	(let ((answer (apply basic-runq ctl)))
						  (if (and (not (cdr runq-task)) (not (basic-runq 'empty?)))
						      (begin
							(set-cdr! runq-task runq-task)
							(superior-runq 'add! runq-task)))
						  answer))))))))
      self)))

;;;;
;;;	(define fork-strips (lambda args args))
;;;		Return a strip that starts several strips in
;;;		parallel.   If this strip is enqueued on a fair
;;;		runq, strips of the parallel subtasks will run
;;;		round-robin style.
;;;
(define fork-strips (lambda args args))

;;;;
;;; 	(strip-sequence . strips)
;;;
;;; 		Returns a new strip which is the concatenation of the argument strips.
;;;
(define ((strip-sequence . strips))
  (let loop ((st (let ((a strips)) (set! strips #f) a)))
    (and (not (null? st))
	 (let ((then ((car st))))
	   (if then
	       (lambda () (loop (cons then (cdr st))))
	       (lambda () (loop (cdr st))))))))

;;;;
;;; 	(fair-strip-subtask . initial-strips)
;;;
;;; 		Returns a new strip which is the synchronos, fair,
;;; 		parallel execution of the argument strips.
;;;
;;;
;;;
(define (fair-strip-subtask . initial-strips)
  (let ((st (make-fair-runq)))
    (apply st 'add! initial-strips)
    st))

;;; runq.scm ends here


code:
;;; installed-scm-file

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

;;; This is the Scheme part of (ice-9 rw), which is a subset of
;;; (scsh rw).

(define-module (ice-9 rw)
  :export (read-string!/partial write-string/partial))

(%init-rw-builtins)


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

;;;; Safe subset of R5RS bindings

(define-module (ice-9 safe-r5rs)
  :re-export (eqv? eq? equal?
	      number?	complex? real? rational? integer?
	      exact? inexact?
	      = < > <= >=
	      zero? positive?	negative? odd? even?
	      max min
	      + * - /
	      abs
	      quotient remainder modulo
	      gcd lcm
	      numerator denominator
	      rationalize
	      floor ceiling truncate round
	      exp log sin cos tan asin acos atan
	      sqrt
	      expt
	      make-rectangular make-polar real-part imag-part magnitude angle
	      exact->inexact inexact->exact

	      number->string string->number

	      boolean?
	      not

	      pair?
	      cons car cdr
	      set-car! set-cdr!
	      caar cadr cdar cddr
	      caaar caadr cadar caddr cdaar cdadr cddar cdddr
	      caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
	      cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
	      null?
	      list?
	      list
	      length
	      append
	      reverse
	      list-tail list-ref
	      memq memv member
	      assq assv assoc

	      symbol?
	      symbol->string string->symbol

	      char?
	      char=? char<? char>? char<=? char>=?
	      char-ci=? char-ci<? char-ci>? char-ci<=? char-ci>=?
	      char-alphabetic? char-numeric? char-whitespace?
	      char-upper-case? char-lower-case?
	      char->integer integer->char
	      char-upcase
	      char-downcase

	      string?
	      make-string
	      string
	      string-length
	      string-ref string-set!
	      string=? string-ci=?
	      string<? string>? string<=? string>=?
	      string-ci<? string-ci>? string-ci<=? string-ci>=?
	      substring
	      string-length
	      string-append
	      string->list list->string
	      string-copy string-fill!

	      vector?
	      make-vector
	      vector
	      vector-length
	      vector-ref vector-set!
	      vector->list list->vector
	      vector-fill!

	      procedure?
	      apply
	      map
	      for-each
	      force

	      call-with-current-continuation

	      values
	      call-with-values
	      dynamic-wind

	      eval

	      input-port? output-port?
	      current-input-port current-output-port

	      read
	      read-char
	      peek-char
	      eof-object?
	      char-ready?

	      write
	      display
	      newline
	      write-char

	      ;;transcript-on
	      ;;transcript-off
	      )

  :export (null-environment))

(define null-interface (resolve-interface '(ice-9 null)))

(module-use! %module-public-interface null-interface)

(define (null-environment n)
  (if (not (= n 5))
      (scm-error 'misc-error 'null-environment
		 "~A is not a valid version"
		 (list n)
		 '()))
  ;; Note that we need to create a *fresh* interface
  (let ((interface (make-module 31)))
    (set-module-kind! interface 'interface)
    (module-use! interface null-interface)
    interface))


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

;;;; Safe subset of R5RS bindings

(define-module (ice-9 safe)
  :export (safe-environment make-safe-module))

(define safe-r5rs-interface (resolve-interface '(ice-9 safe-r5rs)))

(define (safe-environment n)
  (if (not (= n 5))
      (scm-error 'misc-error 'safe-environment
		 "~A is not a valid version"
		 (list n)
		 '()))
  safe-r5rs-interface)

(define (make-safe-module)
  (make-module 1021 (list safe-r5rs-interface)))


code:
;;;; 	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
;;;;

;;; Commentary:

;; (serialize FORM1 ...) and (parallelize FORM1 ...) are useful when
;; you don't trust the thread safety of most of your program, but
;; where you have some section(s) of code which you consider can run
;; in parallel to other sections.
;;
;; They "flag" (with dynamic extent) sections of code to be of
;; "serial" or "parallel" nature and have the single effect of
;; preventing a serial section from being run in parallel with any
;; serial section (including itself).
;;
;; Both serialize and parallelize can be nested.  If so, the
;; inner-most construct is in effect.
;;
;; NOTE 1: A serial section can run in parallel with a parallel
;; section.
;;
;; NOTE 2: If a serial section S is "interrupted" by a parallel
;; section P in the following manner: S = S1 P S2, S2 is not
;; guaranteed to be resumed by the same thread that previously
;; executed S1.
;;
;; WARNING: Spawning new threads within a serial section have
;; undefined effects.  It is OK, though, to spawn threads in unflagged
;; sections of code where neither serialize or parallelize is in
;; effect.
;;
;; A typical usage is when Guile is used as scripting language in some
;; application doing heavy computations.  If each thread is
;; encapsulated with a serialize form, you can then put a parallelize
;; form around the code performing the heavy computations (typically a
;; C code primitive), enabling the computations to run in parallel
;; while the scripting code runs single-threadedly.
;;

;;; Code:

(define-module (ice-9 serialize)
  :use-module (ice-9 threads)
  :export (call-with-serialization
	   call-with-parallelization)
  :export-syntax (serialize
		  parallelize))

(define serialization-mutex (make-mutex))
(define admin-mutex (make-mutex))
(define owner #f)

(define (call-with-serialization thunk)
  (let ((outer-owner #f))
    (dynamic-wind
	(lambda ()
	  (lock-mutex admin-mutex)
	  (set! outer-owner owner)
	  (if (not (eqv? outer-owner (dynamic-root)))
	      (begin
		(unlock-mutex admin-mutex)
		(lock-mutex serialization-mutex)
		(set! owner (dynamic-root)))
	      (unlock-mutex admin-mutex)))
	thunk
	(lambda ()
	  (lock-mutex admin-mutex)
	  (if (not (eqv? outer-owner (dynamic-root)))
	      (begin
		(set! owner #f)
		(unlock-mutex serialization-mutex)))
	  (unlock-mutex admin-mutex)))))

(define-macro (serialize . forms)
  `(call-with-serialization (lambda () ,@forms)))

(define (call-with-parallelization thunk)
  (let ((outer-owner #f))
    (dynamic-wind
	(lambda ()
	  (lock-mutex admin-mutex)
	  (set! outer-owner owner)
	  (if (eqv? outer-owner (dynamic-root))
	      (begin
		(set! owner #f)
		(unlock-mutex serialization-mutex)))
	  (unlock-mutex admin-mutex))
	thunk
	(lambda ()
	  (lock-mutex admin-mutex)
	  (if (eqv? outer-owner (dynamic-root))
	      (begin
		(unlock-mutex admin-mutex)
		(lock-mutex serialization-mutex)
		(set! owner outer-owner))
	      (unlock-mutex admin-mutex))))))

(define-macro (parallelize . forms)
  `(call-with-parallelization (lambda () ,@forms)))


code:
;;;; 	Copyright (C) 1997, 2000, 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 session)
  :use-module (ice-9 documentation)
  :use-module (ice-9 regex)
  :use-module (ice-9 rdelim)
  :export (help
           add-value-help-handler! remove-value-help-handler!
           add-name-help-handler! remove-name-help-handler!
           apropos apropos-internal apropos-fold apropos-fold-accessible
           apropos-fold-exported apropos-fold-all source arity
           system-module module-commentary))

(define *value-help-handlers*
  `(,(lambda (name value)
       (object-documentation value))))

(define (add-value-help-handler! proc)
  "Adds a handler for performing `help' on a value.

`proc' will be called as (PROC NAME VALUE). `proc' should return #t to
indicate that it has performed help, a string to override the default
object documentation, or #f to try the other handlers, potentially
falling back on the normal behavior for `help'."
  (set! *value-help-handlers* (cons proc *value-help-handlers*)))

(define (remove-value-help-handler! proc)
  "Removes a handler for performing `help' on a value."
  (set! *value-help-handlers* (delete! proc *value-help-handlers*)))

(define (try-value-help name value)
  (or-map (lambda (proc) (proc name value)) *value-help-handlers*))

(define *name-help-handlers* '())

(define (add-name-help-handler! proc)
  "Adds a handler for performing `help' on a name.

`proc' will be called with the unevaluated name as its argument. That is
to say, when the user calls `(help FOO)', the name is FOO, exactly as
the user types it.

`proc' should return #t to indicate that it has performed help, a string
to override the default object documentation, or #f to try the other
handlers, potentially falling back on the normal behavior for `help'."
  (set! *name-help-handlers* (cons proc *name-help-handlers*)))

(define (remove-name-help-handler! proc)
  "Removes a handler for performing `help' on a name."
  (set! *name-help-handlers* (delete! proc *name-help-handlers*)))

(define (try-name-help name)
  (or-map (lambda (proc) (proc name)) *name-help-handlers*))

;;; Documentation
;;;
(define help
  (procedure->syntax
    (lambda (exp env)
      "(help [NAME])
Prints useful information.  Try `(help)'."
      (cond ((not (= (length exp) 2))
             (help-usage))
            ((not (provided? 'regex))
             (display "`help' depends on the `regex' feature.
You don't seem to have regular expressions installed.\n"))
            (else
             (let ((name (cadr exp))
                   (not-found (lambda (type x)
                                (simple-format #t "No ~A found for ~A\n"
                                               type x))))
               (cond

                ;; User-specified
                ((try-name-help name)
                 => (lambda (x) (if (not (eq? x #t)) (display x))))

                ;; SYMBOL
                ((symbol? name)
                 (help-doc name
                           (simple-format
                            #f "^~A$"
                            (regexp-quote (symbol->string name)))))

                ;; "STRING"
                ((string? name)
                 (help-doc name name))

                ;; (unquote SYMBOL)
                ((and (list? name)
                      (= (length name) 2)
                      (eq? (car name) 'unquote))
                 (let ((doc (try-value-help (cadr name)
                                            (local-eval (cadr name) env))))
                   (cond ((not doc) (not-found 'documentation (cadr name)))
                         ((eq? doc #t)) ;; pass
                         (else (write-line doc)))))

                ;; (quote SYMBOL)
                ((and (list? name)
                      (= (length name) 2)
                      (eq? (car name) 'quote)
                      (symbol? (cadr name)))
                 (cond ((search-documentation-files (cadr name))
                        => write-line)
                       (else (not-found 'documentation (cadr name)))))

                ;; (SYM1 SYM2 ...)
                ((and (list? name)
                      (and-map symbol? name)
                      (not (null? name))
                      (not (eq? (car name) 'quote)))
                 (cond ((module-commentary name)
                        => (lambda (doc)
                             (display name) (write-line " commentary:")
                             (write-line doc)))
                       (else (not-found 'commentary name))))

                ;; unrecognized
                (else
                 (help-usage)))
               *unspecified*))))))

(define (module-filename name)          ; fixme: better way? / done elsewhere?
  (let* ((name (map symbol->string name))
         (reverse-name (reverse name))
	 (leaf (car reverse-name))
	 (dir-hint-module-name (reverse (cdr reverse-name)))
	 (dir-hint (apply string-append
                          (map (lambda (elt)
                                 (string-append elt "/"))
                               dir-hint-module-name))))
    (%search-load-path (in-vicinity dir-hint leaf))))

(define (module-commentary name)
  (cond ((module-filename name) => file-commentary)
        (else #f)))

(define (help-doc term regexp)
  (let ((entries (apropos-fold (lambda (module name object data)
				 (cons (list module
					     name
					     (try-value-help name object)
					     (cond ((closure? object)
						    "a procedure")
						   ((procedure? object)
						    "a primitive procedure")
						   (else
						    "an object")))
				       data))
			       '()
			       regexp
			       apropos-fold-exported))
	(module car)
	(name cadr)
	(doc caddr)
	(type cadddr))
    (cond ((not (null? entries))
           (let ((first? #t)
                 (undocumented-entries '())
                 (documented-entries '())
                 (documentations '()))

             (for-each (lambda (entry)
                         (let ((entry-summary (simple-format
                                               #f "~S: ~S\n"
                                               (module-name (module entry))
                                               (name entry))))
                           (if (doc entry)
                               (begin
                                 (set! documented-entries
                                       (cons entry-summary documented-entries))
                                 ;; *fixme*: Use `describe' when we have GOOPS?
                                 (set! documentations
                                       (cons (simple-format
                                              #f "`~S' is ~A in the ~S module.\n\n~A\n"
                                              (name entry)
                                              (type entry)
                                              (module-name (module entry))
                                              (doc entry))
                                             documentations)))
                               (set! undocumented-entries
                                     (cons entry-summary
                                           undocumented-entries)))))
                       entries)

             (if (and (not (null? documented-entries))
                      (or (> (length documented-entries) 1)
                          (not (null? undocumented-entries))))
                 (begin
                   (display "Documentation found for:\n")
                   (for-each (lambda (entry) (display entry))
                             documented-entries)
                   (set! first? #f)))

             (for-each (lambda (entry)
                         (if first?
                             (set! first? #f)
                             (newline))
                         (display entry))
                       documentations)

             (if (not (null? undocumented-entries))
                 (begin
                   (if first?
                       (set! first? #f)
                       (newline))
                   (display "No documentation found for:\n")
                   (for-each (lambda (entry) (display entry))
                             undocumented-entries)))))
          ((search-documentation-files term)
           => (lambda (doc)
                (write-line "Documentation from file:")
                (write-line doc)))
          (else
           ;; no matches
           (display "Did not find any object ")
           (simple-format #t
                          (if (symbol? term)
                              "named `~A'\n"
                              "matching regexp \"~A\"\n")
                          term)))))

(define (help-usage)
  (display "Usage: (help NAME) gives documentation about objects named NAME (a symbol)
       (help REGEXP) ditto for objects with names matching REGEXP (a string)
       (help 'NAME) gives documentation for NAME, even if it is not an object
       (help ,EXPR) gives documentation for object returned by EXPR
       (help (my module)) gives module commentary for `(my module)'
       (help) gives this text

`help' searches among bindings exported from loaded modules, while
`apropos' searches among bindings visible from the \"current\" module.

Examples: (help help)
          (help cons)
          (help \"output-string\")

Other useful sources of helpful information:

(apropos STRING)
(arity PROCEDURE)
(name PROCEDURE-OR-MACRO)
(source PROCEDURE-OR-MACRO)

Tools:

(backtrace)				;show backtrace from last error
(debug)					;enter the debugger
(trace [PROCEDURE])			;trace procedure (no arg => show)
(untrace [PROCEDURE])			;untrace (no arg => untrace all)

(OPTIONSET-options 'full)		;display option information
(OPTIONSET-enable 'OPTION)
(OPTIONSET-disable 'OPTION)
(OPTIONSET-set! OPTION VALUE)

where OPTIONSET is one of debug, read, eval, print

"))

;;; {Apropos}
;;;
;;; Author: Roland Orre <orre@nada.kth.se>
;;;

(define (apropos rgx . options)
  "Search for bindings: apropos regexp {options= 'full 'shadow 'value}"
  (if (zero? (string-length rgx))
      "Empty string not allowed"
      (let* ((match (make-regexp rgx))
	     (uses (module-uses (current-module)))
	     (modules (cons (current-module)
			    (if (and (not (null? uses))
				     (eq? (module-name (car uses))
					  'duplicates))
				(cdr uses)
				uses)))
	     (separator #\tab)
	     (shadow (member 'shadow options))
	     (value (member 'value options)))
	(cond ((member 'full options)
	       (set! shadow #t)
	       (set! value #t)))
	(for-each
	 (lambda (module)
	   (let* ((name (module-name module))
		  (obarray (module-obarray module)))
	     ;; XXX - should use hash-fold here
	     (hash-for-each
	      (lambda (symbol variable)
		(cond ((regexp-exec match (symbol->string symbol))
		       (display name)
		       (display ": ")
		       (display symbol)
		       (cond ((variable-bound? variable)
			      (let ((val (variable-ref variable)))
				(cond ((or (procedure? val) value)
				       (display separator)
				       (display val)))))
			     (else
			      (display separator)
			      (display "(unbound)")))
		       (if (and shadow
				(not (eq? (module-ref module symbol)
					  (module-ref (current-module) symbol))))
			   (display " shadowed"))
		       (newline))))
	      obarray)))
	 modules))))

(define (apropos-internal rgx)
  "Return a list of accessible variable names."
  (apropos-fold (lambda (module name var data)
		  (cons name data))
		'()
		rgx
		(apropos-fold-accessible (current-module))))

(define (apropos-fold proc init rgx folder)
  "Folds PROCEDURE over bindings matching third arg REGEXP.

Result is

  (PROCEDURE MODULE1 NAME1 VALUE1
    (PROCEDURE MODULE2 NAME2 VALUE2
      ...
      (PROCEDURE MODULEn NAMEn VALUEn INIT)))

where INIT is the second arg to `apropos-fold'.

Fourth arg FOLDER is one of

  (apropos-fold-accessible MODULE) ;fold over bindings accessible in MODULE
  apropos-fold-exported		   ;fold over all exported bindings
  apropos-fold-all		   ;fold over all bindings"
  (let ((match (make-regexp rgx))
	(recorded (make-vector 61 '())))
    (let ((fold-module
	   (lambda (module data)
	     (let* ((obarray-filter
		     (lambda (name val data)
		       (if (and (regexp-exec match (symbol->string name))
				(not (hashq-get-handle recorded name)))
			   (begin
			     (hashq-set! recorded name #t)
			     (proc module name val data))
			   data)))
		    (module-filter
		     (lambda (name var data)
		       (if (variable-bound? var)
			   (obarray-filter name (variable-ref var) data)
			   data))))
	       (cond (module (hash-fold module-filter
					data
					(module-obarray module)))
		     (else data))))))
      (folder fold-module init))))

(define (make-fold-modules init-thunk traverse extract)
  "Return procedure capable of traversing a forest of modules.
The forest traversed is the image of the forest generated by root
modules returned by INIT-THUNK and the generator TRAVERSE.
It is an image under the mapping EXTRACT."
  (lambda (fold-module init)
    (let* ((table (make-hash-table 31))
	   (first? (lambda (obj)
		     (let* ((handle (hash-create-handle! table obj #t))
			    (first? (cdr handle)))
		       (set-cdr! handle #f)
		       first?))))
      (let rec ((data init)
		(modules (init-thunk)))
	(do ((modules modules (cdr modules))
	     (data data (if (first? (car modules))
			    (rec (fold-module (extract (car modules)) data)
				 (traverse (car modules)))
			    data)))
	    ((null? modules) data))))))

(define (apropos-fold-accessible module)
  (make-fold-modules (lambda () (list module))
		     module-uses
		     identity))

(define (root-modules)
  (cons the-root-module
	(submodules (nested-ref the-root-module '(app modules)))))

(define (submodules m)
  (hash-fold (lambda (name var data)
	       (let ((obj (and (variable-bound? var) (variable-ref var))))
		 (if (and (module? obj)
			  (eq? (module-kind obj) 'directory))
		     (cons obj data)
		     data)))
	     '()
	     (module-obarray m)))

(define apropos-fold-exported
  (make-fold-modules root-modules submodules module-public-interface))

(define apropos-fold-all
  (make-fold-modules root-modules submodules identity))

(define (source obj)
  (cond ((procedure? obj) (procedure-source obj))
	((macro? obj) (procedure-source (macro-transformer obj)))
	(else #f)))

(define (arity obj)
  (define (display-arg-list arg-list)
    (display #\`)
    (display (car arg-list))
    (let loop ((ls (cdr arg-list)))
      (cond ((null? ls)
	     (display #\'))
	    ((not (pair? ls))
	     (display "', the rest in `")
	     (display ls)
	     (display #\'))
	    (else
	     (if (pair? (cdr ls))
		 (display "', `")
		 (display "' and `"))
	     (display (car ls))
	     (loop (cdr ls))))))
  (define (display-arg-list/summary arg-list type)
    (let ((len (length arg-list)))
      (display len)
      (display " ")
      (display type)
      (if (> len 1)
	  (display " arguments: ")
	  (display " argument: "))
      (display-arg-list arg-list)))
  (cond
   ((procedure-property obj 'arglist)
    => (lambda (arglist)
	 (let ((required-args (car arglist))
	       (optional-args (cadr arglist))
	       (keyword-args (caddr arglist))
	       (allow-other-keys? (cadddr arglist))
	       (rest-arg (car (cddddr arglist)))
	       (need-punctuation #f))
	   (cond ((not (null? required-args))
		  (display-arg-list/summary required-args "required")
		  (set! need-punctuation #t)))
	   (cond ((not (null? optional-args))
		  (if need-punctuation (display ", "))
		  (display-arg-list/summary optional-args "optional")
		  (set! need-punctuation #t)))
	   (cond ((not (null? keyword-args))
		  (if need-punctuation (display ", "))
		  (display-arg-list/summary keyword-args "keyword")
		  (set! need-punctuation #t)))
	   (cond (allow-other-keys?
		  (if need-punctuation (display ", "))
		  (display "other keywords allowed")
		  (set! need-punctuation #t)))
	   (cond (rest-arg
		  (if need-punctuation (display ", "))
		  (display "the rest in `")
		  (display rest-arg)
		  (display "'"))))))
   (else
    (let ((arity (procedure-property obj 'arity)))
      (display (car arity))
      (cond ((caddr arity)
	     (display " or more"))
	    ((not (zero? (cadr arity)))
	     (display " required and ")
	     (display (cadr arity))
	     (display " optional")))
      (if (and (not (caddr arity))
	       (= (car arity) 1)
	       (<= (cadr arity) 1))
	  (display " argument")
	  (display " arguments"))
      (if (closure? obj)
	  (let ((formals (cadr (procedure-source obj))))
	    (cond
	     ((pair? formals)
	      (display ": ")
	      (display-arg-list formals))
	     (else
	      (display " in `")
	      (display formals)
	      (display #\'))))))))
  (display ".\n"))

(define system-module
  (procedure->syntax
   (lambda (exp env)
     (let* ((m (nested-ref the-root-module
			   (append '(app modules) (cadr exp)))))
       (if (not m)
	   (error "Couldn't find any module named" (cadr exp)))
       (let ((s (not (procedure-property (module-eval-closure m)
					 'system-module))))
	 (set-system-module! m s)
	 (string-append "Module " (symbol->string (module-name m))
			" is now a " (if s "system" "user") " module."))))))

;;; session.scm ends here


code:
;;;; slib.scm --- definitions needed to get SLIB to work with Guile
;;;;
;;;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2006, 2007 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 slib)
  :export (slib:load slib:load-source defmacro:load
	   implementation-vicinity library-vicinity home-vicinity
	   scheme-implementation-type scheme-implementation-version
	   output-port-width output-port-height array-indexes
	   make-random-state
	   -1+ <? <=? =? >? >=?
	   require slib:error slib:exit slib:warn slib:eval
	   defmacro:eval logical:logand logical:logior logical:logxor
	   logical:lognot logical:ash logical:logcount logical:integer-length
	   logical:bit-extract logical:integer-expt logical:ipow-by-squaring
	   slib:eval-load slib:tab slib:form-feed difftime offset-time
	   software-type)
  :no-backtrace)

;; Initialize SLIB.
(load-from-path "slib/guile.init")

;; SLIB redefines a few core symbols based on their default definition.
;; Thus, we only replace them at this point so that their previous definition
;; is visible when `guile.init' is loaded.
(module-replace! (current-module)
                 '(delete-file open-file provide provided? system))


code:
;;; installed-scm-file

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

(define-module (ice-9 stack-catch)
  :export (stack-catch))

(define (stack-catch key thunk handler)
  "Like @code{catch}, invoke @var{thunk} in the dynamic context of
@var{handler} for exceptions matching @var{key}, but also save the
current stack state in the @var{the-last-stack} fluid, for the purpose
of debugging or re-throwing of an error.  If thunk throws to the
symbol @var{key}, then @var{handler} is invoked this way:\n
@example
 (handler key args ...)
@end example\n
@var{key} is a symbol or #t.\n
@var{thunk} takes no arguments.  If @var{thunk} returns normally, that
is the return value of @code{catch}.\n
Handler is invoked outside the scope of its own @code{catch}.  If
@var{handler} again throws to the same key, a new handler from further
up the call chain is invoked.\n
If the key is @code{#t}, then a throw to @emph{any} symbol will match
this call to @code{catch}."
  (catch key
	 thunk
	 handler
	 lazy-handler-dispatch))


code:
;;;; streams.scm --- general lazy streams
;;;; -*- Scheme -*-

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

;; the basic stream operations are inspired by
;; (i.e. ripped off) Scheme48's `stream' package,
;; modulo stream-empty? -> stream-null? renaming.

(define-module (ice-9 streams)
  :export (make-stream
	   stream-car stream-cdr stream-null?
	   list->stream vector->stream port->stream
	   stream->list stream->reversed-list
	   stream->list&length stream->reversed-list&length
	   stream->vector
	   stream-fold stream-for-each stream-map))

;; Use:
;;
;; (make-stream producer initial-state)
;;  - PRODUCER is a function of one argument, the current state.
;;    it should return either a pair or an atom (i.e. anything that
;;    is not a pair).  if PRODUCER returns a pair, then the car of the pair
;;    is the stream's head value, and the cdr is the state to be fed
;;    to PRODUCER later.  if PRODUCER returns an atom, then the stream is
;;    considered depleted.
;;
;; (stream-car stream)
;; (stream-cdr stream)
;; (stream-null? stream)
;;  - yes.
;;
;; (list->stream list)
;; (vector->stream vector)
;;  - make a stream with the same contents as LIST/VECTOR.
;;
;; (port->stream port read)
;;  - makes a stream of values which are obtained by READing from PORT.
;;
;; (stream->list stream)
;;  - returns a list with the same contents as STREAM.
;;
;; (stream->reversed-list stream)
;;  - as above, except the contents are in reversed order.
;;
;; (stream->list&length stream)
;; (stream->reversed-list&length stream)
;;  - multiple-valued versions of the above two, the second value is the
;;    length of the resulting list (so you get it for free).
;;
;; (stream->vector stream)
;;  - yes.
;;
;; (stream-fold proc init stream0 ...)
;;  - PROC must take (+ 1 <number-of-stream-arguments>) arguments, like this:
;;    (PROC car0 ... init).  *NOTE*: the INIT argument is last, not first.
;;    I don't have any preference either way, but it's consistent with
;;    `fold[lr]' procedures from SRFI-1.  PROC is applied to successive
;;    elements of the given STREAM(s) and to the value of the previous
;;    invocation (INIT on the first invocation).  the last result from PROC
;;    is returned.
;;
;; (stream-for-each proc stream0 ...)
;;  - like `for-each' we all know and love.
;;
;; (stream-map proc stream0 ...)
;;  - like `map', except returns a stream of results, and not a list.

;; Code:

(define (make-stream m state)
  (delay
    (let ((o (m state)))
      (if (pair? o)
	  (cons (car o)
		(make-stream m (cdr o)))
          '()))))

(define (stream-car stream)
  "Returns the first element in STREAM.  This is equivalent to `car'."
  (car (force stream)))

(define (stream-cdr stream)
  "Returns the first tail of STREAM. Equivalent to `(force (cdr STREAM))'."
  (cdr (force stream)))

(define (stream-null? stream)
  "Returns `#t' if STREAM is the end-of-stream marker; otherwise
returns `#f'.  This is equivalent to `null?', but should be used
whenever testing for the end of a stream."
  (null? (force stream)))

(define (list->stream l)
  "Returns a newly allocated stream whose elements are the elements of
LIST.  Equivalent to `(apply stream LIST)'."
  (make-stream
   (lambda (l) l)
   l))

(define (vector->stream v)
  (make-stream
   (let ((len (vector-length v)))
     (lambda (i)
       (or (= i len)
           (cons (vector-ref v i) (+ 1 i)))))
   0))

(define (stream->reversed-list&length stream)
  (let loop ((s stream) (acc '()) (len 0))
    (if (stream-null? s)
        (values acc len)
        (loop (stream-cdr s) (cons (stream-car s) acc) (+ 1 len)))))

(define (stream->reversed-list stream)
  (call-with-values
   (lambda () (stream->reversed-list&length stream))
   (lambda (l len) l)))

(define (stream->list&length stream)
  (call-with-values
   (lambda () (stream->reversed-list&length stream))
   (lambda (l len) (values (reverse! l) len))))

(define (stream->list stream)
  "Returns a newly allocated list whose elements are the elements of STREAM.
If STREAM has infinite length this procedure will not terminate."
  (reverse! (stream->reversed-list stream)))

(define (stream->vector stream)
  (call-with-values
   (lambda () (stream->reversed-list&length stream))
   (lambda (l len)
     (let ((v (make-vector len)))
       (let loop ((i 0) (l l))
         (if (not (null? l))
             (begin
               (vector-set! v (- len i 1) (car l))
               (loop (+ 1 i) (cdr l)))))
       v))))

(define (stream-fold f init stream . rest)
  (if (null? rest) ;fast path
      (stream-fold-one f init stream)
      (stream-fold-many f init (cons stream rest))))

(define (stream-fold-one f r stream)
  (if (stream-null? stream)
      r
      (stream-fold-one f (f (stream-car stream) r) (stream-cdr stream))))

(define (stream-fold-many f r streams)
  (if (or-map stream-null? streams)
      r
      (stream-fold-many f
                        (apply f (let recur ((cars
                                              (map stream-car streams)))
                                   (if (null? cars)
                                       (list r)
                                       (cons (car cars)
                                             (recur (cdr cars))))))
                        (map stream-cdr streams))))

(define (stream-for-each f stream . rest)
  (if (null? rest) ;fast path
      (stream-for-each-one f stream)
      (stream-for-each-many f (cons stream rest))))

(define (stream-for-each-one f stream)
  (if (not (stream-null? stream))
      (begin
        (f (stream-car stream))
        (stream-for-each-one f (stream-cdr stream)))))

(define (stream-for-each-many f streams)
  (if (not (or-map stream-null? streams))
      (begin
        (apply f (map stream-car streams))
        (stream-for-each-many f (map stream-cdr streams)))))

(define (stream-map f stream . rest)
  "Returns a newly allocated stream, each element being the result of
invoking F with the corresponding elements of the STREAMs
as its arguments."
  (if (null? rest) ;fast path
      (make-stream (lambda (s)
                     (or (stream-null? s)
                         (cons (f (stream-car s)) (stream-cdr s))))
                   stream)
      (make-stream (lambda (streams)
                     (or (or-map stream-null? streams)
                         (cons (apply f (map stream-car streams))
                               (map stream-cdr streams))))
                   (cons stream rest))))

(define (port->stream port read)
  (make-stream (lambda (p)
                 (let ((o (read p)))
                   (or (eof-object? o)
                       (cons o p))))
               port))

;;; streams.scm ends here


code:
;;;; string-fun.scm --- string manipulation functions
;;;;
;;;; 	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 string-fun)
  :export (split-after-char split-before-char split-discarding-char
	   split-after-char-last split-before-char-last
	   split-discarding-char-last split-before-predicate
	   split-after-predicate split-discarding-predicate
	   separate-fields-discarding-char separate-fields-after-char
	   separate-fields-before-char string-prefix-predicate string-prefix=?
	   sans-surrounding-whitespace sans-trailing-whitespace
	   sans-leading-whitespace sans-final-newline has-trailing-newline?))

;;;;
;;;
;;; Various string funcitons, particularly those that take
;;; advantage of the "shared substring" capability.
;;;

;;; {String Fun: Dividing Strings Into Fields}
;;;
;;; The names of these functions are very regular.
;;; Here is a grammar of a call to one of these:
;;;
;;;   <string-function-invocation>
;;;   := (<action>-<seperator-disposition>-<seperator-determination> <seperator-param> <str> <ret>)
;;;
;;; <str>    = the string
;;;
;;; <ret>    = The continuation.  String functions generally return
;;;	       multiple values by passing them to this procedure.
;;;
;;; <action> =    split
;;;		| separate-fields
;;;
;;;		"split" means to divide a string into two parts.
;;;			<ret> will be called with two arguments.
;;;
;;;		"separate-fields" means to divide a string into as many
;;;			parts as possible.  <ret> will be called with
;;;			however many fields are found.
;;;
;;; <seperator-disposition> = 	  before
;;;				| after
;;;				| discarding
;;;
;;;		"before" means to leave the seperator attached to
;;;			the beginning of the field to its right.
;;;		"after" means to leave the seperator attached to
;;;			the end of the field to its left.
;;;		"discarding" means to discard seperators.
;;;
;;;		Other dispositions might be handy.  For example, "isolate"
;;;		could mean to treat the separator as a field unto itself.
;;;
;;; <seperator-determination> =	  char
;;;				| predicate
;;;
;;;		"char" means to use a particular character as field seperator.
;;;		"predicate" means to check each character using a particular predicate.
;;;
;;;		Other determinations might be handy.  For example, "character-set-member".
;;;
;;; <seperator-param> = A parameter that completes the meaning of the determinations.
;;;			For example, if the determination is "char", then this parameter
;;;			says which character.  If it is "predicate", the parameter is the
;;;			predicate.
;;;
;;;
;;; For example:
;;;
;;;		(separate-fields-discarding-char #\, "foo, bar, baz, , bat" list)
;;;		=> ("foo" " bar" " baz" " " " bat")
;;;
;;;		(split-after-char #\- 'an-example-of-split list)
;;;		=> ("an-" "example-of-split")
;;;
;;; As an alternative to using a determination "predicate", or to trying to do anything
;;; complicated with these functions, consider using regular expressions.
;;;

(define (split-after-char char str ret)
  (let ((end (cond
	      ((string-index str char) => 1+)
	      (else (string-length str)))))
    (ret (substring str 0 end)
	 (substring str end))))

(define (split-before-char char str ret)
  (let ((end (or (string-index str char)
		 (string-length str))))
    (ret (substring str 0 end)
	 (substring str end))))

(define (split-discarding-char char str ret)
  (let ((end (string-index str char)))
    (if (not end)
	(ret str "")
	(ret (substring str 0 end)
	     (substring str (1+ end))))))

(define (split-after-char-last char str ret)
  (let ((end (cond
	      ((string-rindex str char) => 1+)
	      (else 0))))
    (ret (substring str 0 end)
	 (substring str end))))

(define (split-before-char-last char str ret)
  (let ((end (or (string-rindex str char) 0)))
    (ret (substring str 0 end)
	 (substring str end))))

(define (split-discarding-char-last char str ret)
  (let ((end (string-rindex str char)))
    (if (not end)
	(ret str "")
	(ret (substring str 0 end)
	     (substring str (1+ end))))))

(define (split-before-predicate pred str ret)
  (let loop ((n 0))
    (cond
     ((= n (string-length str))		(ret str ""))
     ((not (pred (string-ref str n)))	(loop (1+ n)))
     (else				(ret (substring str 0 n)
					     (substring str n))))))
(define (split-after-predicate pred str ret)
  (let loop ((n 0))
    (cond
     ((= n (string-length str))		(ret str ""))
     ((not (pred (string-ref str n)))	(loop (1+ n)))
     (else				(ret (substring str 0 (1+ n))
					     (substring str (1+ n)))))))

(define (split-discarding-predicate pred str ret)
  (let loop ((n 0))
    (cond
     ((= n (string-length str))		(ret str ""))
     ((not (pred (string-ref str n)))	(loop (1+ n)))
     (else				(ret (substring str 0 n)
					     (substring str (1+ n)))))))

(define (separate-fields-discarding-char ch str ret)
  (let loop ((fields '())
	     (str str))
    (cond
     ((string-rindex str ch)
      => (lambda (w) (loop (cons (substring str (+ 1 w)) fields)
			   (substring str 0 w))))
     (else (apply ret str fields)))))

(define (separate-fields-after-char ch str ret)
  (reverse
   (let loop ((fields '())
             (str str))
     (cond
      ((string-index str ch)
       => (lambda (w) (loop (cons (substring str 0 (+ 1 w)) fields)
                           (substring str (+ 1 w)))))
      (else (apply ret str fields))))))

(define (separate-fields-before-char ch str ret)
  (let loop ((fields '())
	     (str str))
    (cond
     ((string-rindex str ch)
      => (lambda (w) (loop (cons (substring str w) fields)
			     (substring str 0 w))))
     (else (apply ret str fields)))))

;;; {String Fun: String Prefix Predicates}
;;;
;;; Very simple:
;;;
;;; (define-public ((string-prefix-predicate pred?) prefix str)
;;;  (and (<= (string-length prefix) (string-length str))
;;;	  (pred? prefix (substring str 0 (string-length prefix)))))
;;;
;;; (define-public string-prefix=? (string-prefix-predicate string=?))
;;;

(define ((string-prefix-predicate pred?) prefix str)
  (and (<= (string-length prefix) (string-length str))
       (pred? prefix (substring str 0 (string-length prefix)))))

(define string-prefix=? (string-prefix-predicate string=?))

;;; {String Fun: Strippers}
;;;
;;; <stripper> = sans-<removable-part>
;;;
;;; <removable-part> = 	  surrounding-whitespace
;;;			| trailing-whitespace
;;;			| leading-whitespace
;;;			| final-newline
;;;

(define (sans-surrounding-whitespace s)
  (let ((st 0)
	(end (string-length s)))
    (while (and (< st (string-length s))
		(char-whitespace? (string-ref s st)))
	   (set! st (1+ st)))
    (while (and (< 0 end)
		(char-whitespace? (string-ref s (1- end))))
	   (set! end (1- end)))
    (if (< end st)
	""
	(substring s st end))))

(define (sans-trailing-whitespace s)
  (let ((st 0)
	(end (string-length s)))
    (while (and (< 0 end)
		(char-whitespace? (string-ref s (1- end))))
	   (set! end (1- end)))
    (if (< end st)
	""
	(substring s st end))))

(define (sans-leading-whitespace s)
  (let ((st 0)
	(end (string-length s)))
    (while (and (< st (string-length s))
		(char-whitespace? (string-ref s st)))
	   (set! st (1+ st)))
    (if (< end st)
	""
	(substring s st end))))

(define (sans-final-newline str)
  (cond
   ((= 0 (string-length str))
    str)

   ((char=? #\nl (string-ref str (1- (string-length str))))
    (substring str 0 (1- (string-length str))))

   (else str)))

;;; {String Fun: has-trailing-newline?}
;;;

(define (has-trailing-newline? str)
  (and (< 0 (string-length str))
       (char=? #\nl (string-ref str (1- (string-length str))))))

;;; {String Fun: with-regexp-parts}

;;; This relies on the older, hairier regexp interface, which we don't
;;; particularly want to implement, and it's not used anywhere, so
;;; we're just going to drop it for now.
;;; (define-public (with-regexp-parts regexp fields str return fail)
;;;   (let ((parts (regexec regexp str fields)))
;;;     (if (number? parts)
;;;         (fail parts)
;;;         (apply return parts))))


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

(define-module (ice-9 syncase)
  :use-module (ice-9 debug)
  :use-module (ice-9 threads)
  :export-syntax (sc-macro define-syntax
                  eval-when fluid-let-syntax
		  let-syntax
		  letrec-syntax syntax syntax-case)
  :export (sc-expand sc-expand3 install-global-transformer
	   syntax-dispatch syntax-error bound-identifier=?
	   datum->syntax-object free-identifier=?
	   generate-temporaries identifier? syntax-object->datum
	   void syncase)
  :replace (eval))

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

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

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

;;; Exported variables

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

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

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

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

;;; Hooks needed by the syntax-case macro package

(define (void) *unspecified*)

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

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

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

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

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

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

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

(define generated-symbols (make-weak-key-hash-table 1019))

;; We define our own gensym here because the Guile built-in one will
;; eventually produce uninterned and unreadable symbols (as needed for
;; safe macro expansions) and will the be inappropriate for dumping to
;; pssyntax.pp.
;;
;; syncase is supposed to only require that gensym produce unique
;; readable symbols, and they only need be unique with respect to
;; multiple calls to gensym, not globally unique.
;;
(define gensym
  (let ((counter 0))

    (define next-id
      (if (provided? 'threads)
          (let ((symlock (make-mutex)))
            (lambda ()
              (let ((result #f))
                (with-mutex symlock
                  (set! result counter)
                  (set! counter (+ counter 1)))
                result)))
          ;; faster, non-threaded case.
          (lambda ()
            (let ((result counter))
              (set! counter (+ counter 1))
              result))))

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

;;; Load the preprocessed code

(let ((old-debug #f)
      (old-read #f))
  (dynamic-wind (lambda ()
		  (set! old-debug (debug-options))
		  (set! old-read (read-options)))
		(lambda ()
		  (debug-disable 'debug 'procnames)
		  (read-disable 'positions)
		  (load-from-path "ice-9/psyntax.pp"))
		(lambda ()
		  (debug-options old-debug)
		  (read-options old-read))))

;;; The following lines are necessary only if we start making changes
;; (use-syntax sc-expand)
;; (load-from-path "ice-9/psyntax.ss")

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

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

;;; Hack to make syncase macros work in the slib module
(let ((m (nested-ref the-root-module '(%app modules ice-9 slib))))
  (if m
      (set-object-property! (module-local-variable m 'define)
			    '*sc-expander*
			    '(define))))

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

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

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