LilyPond-Ruby 0.0.2.1 → 0.1.2

data/share/guile/2.2/ice-9/buffered-input.scm

@@ -0,0 +1,109 @@
+;;;; buffered-input.scm --- construct a port from a buffered input reader
+;;;;
+;;;; 	Copyright (C) 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 buffered-input)
+  #:export (make-buffered-input-port
+            make-line-buffered-input-port
+            set-buffered-input-continuation?!))
+
+;; @code{buffered-input-continuation?} is a property of the ports
+;; created by @code{make-line-buffered-input-port} that stores the
+;; read continuation flag for each such port.
+(define buffered-input-continuation? (make-object-property))
+
+(define (set-buffered-input-continuation?! port val)
+  "Set the read continuation flag for @var{port} to @var{val}.
+
+See @code{make-buffered-input-port} for the meaning and use of this
+flag."
+  (set! (buffered-input-continuation? port) val))
+
+(define (make-buffered-input-port reader)
+  "Construct a line-buffered input port from the specified @var{reader}.
+@var{reader} should be a procedure of one argument that somehow reads
+a chunk of input and returns it as a string.
+
+The port created by @code{make-buffered-input-port} does @emph{not}
+interpolate any additional characters between the strings returned by
+@var{reader}.
+
+@var{reader} should take a boolean @var{continuation?} argument.
+@var{continuation?} indicates whether @var{reader} is being called to
+start a logically new read operation (in which case
+@var{continuation?} is @code{#f}) or to continue a read operation for
+which some input has already been read (in which case
+@var{continuation?} is @code{#t}).  Some @var{reader} implementations
+use the @var{continuation?} argument to determine what prompt to
+display to the user.
+
+The new/continuation distinction is largely an application-level
+concept: @code{set-buffered-input-continuation?!} allows an
+application to specify when a read operation is considered to be new.
+But note that if there is non-whitespace data already buffered in the
+port when a new read operation starts, this data will be read before
+the first call to @var{reader}, and so @var{reader} will be called
+with @var{continuation?} set to @code{#t}."
+  (let ((read-string "")
+	(string-index 0))
+    (letrec ((get-character
+	      (lambda ()
+		(if (< string-index (string-length read-string))
+                    ;; Read a char.
+                    (let ((res (string-ref read-string string-index)))
+                      (set! string-index (+ 1 string-index))
+                      (if (not (char-whitespace? res))
+                          (set! (buffered-input-continuation? port) #t))
+                      res)
+                    ;; Fill the buffer.
+                    (let ((x (reader (buffered-input-continuation? port))))
+                      (cond
+                       ((eof-object? x)
+                        ;; Don't buffer the EOF object.
+                        x)
+                       (else
+                        (set! read-string x)
+                        (set! string-index 0)
+                        (get-character)))))))
+	     (input-waiting
+	      (lambda ()
+                (- (string-length read-string) string-index)))
+             (port #f))
+      (set! port (make-soft-port (vector #f #f #f get-character #f input-waiting) "r"))
+      (set! (buffered-input-continuation? port) #f)
+      port)))
+
+(define (make-line-buffered-input-port reader)
+  "Construct a line-buffered input port from the specified @var{reader}.
+@var{reader} should be a procedure of one argument that somehow reads
+a line of input and returns it as a string @emph{without} the
+terminating newline character.
+
+The port created by @code{make-line-buffered-input-port} automatically
+interpolates a newline character after each string returned by
+@var{reader}.
+
+@var{reader} should take a boolean @var{continuation?} argument.  For
+the meaning and use of this argument, see
+@code{make-buffered-input-port}."
+  (make-buffered-input-port (lambda (continuation?)
+                              (let ((str (reader continuation?)))
+                                (if (eof-object? str)
+                                    str
+                                    (string-append str "\n"))))))
+
+;;; buffered-input.scm ends here

data/share/guile/2.2/ice-9/calling.scm

@@ -0,0 +1,326 @@
+;;;; calling.scm --- Calling Conventions
+;;;;
+;;;; 	Copyright (C) 1995, 1996, 1997, 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 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 calling)
+  :export-syntax (with-excursion-function
+		  with-getter-and-setter
+		  with-getter
+		  with-delegating-getter-and-setter
+		  with-excursion-getter-and-setter
+		  with-configuration-getter-and-setter
+		  with-delegating-configuration-getter-and-setter
+		  let-with-configuration-getter-and-setter))
+
+;;;;
+;;;
+;;; This file contains a number of macros that support 
+;;; common calling conventions.
+
+;;;
+;;; with-excursion-function <vars> proc
+;;;  <vars> is an unevaluated list of names that are bound in the caller.
+;;;  proc is a procedure, called:
+;;;	     (proc excursion)
+;;;
+;;;  excursion is a procedure isolates all changes to <vars>
+;;;  in the dynamic scope of the call to proc.  In other words,
+;;;  the values of <vars> are saved when proc is entered, and when
+;;;  proc returns, those values are restored.   Values are also restored
+;;;  entering and leaving the call to proc non-locally, such as using
+;;;  call-with-current-continuation, error, or throw.
+;;;
+(defmacro with-excursion-function (vars proc)
+  `(,proc ,(excursion-function-syntax vars)))
+
+
+
+;;; with-getter-and-setter <vars> proc
+;;;  <vars> is an unevaluated list of names that are bound in the caller.
+;;;  proc is a procedure, called:
+;;;	(proc getter setter)
+;;; 
+;;;  getter and setter are procedures used to access
+;;;  or modify <vars>.
+;;; 
+;;;  setter, called with keywords arguments, modifies the named
+;;;  values.   If "foo" and "bar" are among <vars>, then:
+;;; 
+;;;	(setter :foo 1 :bar 2)
+;;;	== (set! foo 1 bar 2)
+;;; 
+;;;  getter, called with just keywords, returns
+;;;  a list of the corresponding values.  For example,
+;;;  if "foo" and "bar" are among the <vars>, then
+;;; 
+;;;	(getter :foo :bar)
+;;;	=> (<value-of-foo> <value-of-bar>)
+;;; 
+;;;  getter, called with no arguments, returns a list of all accepted 
+;;;  keywords and the corresponding values.  If "foo" and "bar" are
+;;;  the *only* <vars>, then:
+;;; 
+;;;	(getter)
+;;;	=> (:foo <value-of-bar> :bar <value-of-foo>)
+;;; 
+;;;  The unusual calling sequence of a getter supports too handy
+;;;  idioms:
+;;; 
+;;;	(apply setter (getter))		;; save and restore
+;;; 
+;;;	(apply-to-args (getter :foo :bar)		;; fetch and bind
+;;;		    (lambda (foo bar) ....))
+;;; 
+;;;     ;; [ "apply-to-args" is just like two-argument "apply" except that it 
+;;;	;;   takes its arguments in a different order.
+;;; 
+;;;
+(defmacro with-getter-and-setter (vars proc)
+  `(,proc ,@ (getter-and-setter-syntax vars)))
+
+;;; with-getter vars proc
+;;;   A short-hand for a call to with-getter-and-setter.
+;;;   The procedure is called:
+;;;		(proc getter)
+;;;
+(defmacro with-getter (vars proc)
+  `(,proc ,(car (getter-and-setter-syntax vars))))
+
+
+;;; with-delegating-getter-and-setter <vars> get-delegate set-delegate proc
+;;;   Compose getters and setters.
+;;; 
+;;;   <vars> is an unevaluated list of names that are bound in the caller.
+;;;   
+;;;   get-delegate is called by the new getter to extend the set of 
+;;;	gettable variables beyond just <vars>
+;;;   set-delegate is called by the new setter to extend the set of 
+;;;	gettable variables beyond just <vars>
+;;;
+;;;   proc is a procedure that is called
+;;;		(proc getter setter)
+;;;
+(defmacro with-delegating-getter-and-setter (vars get-delegate set-delegate proc)
+  `(,proc ,@ (delegating-getter-and-setter-syntax vars get-delegate set-delegate)))
+
+
+;;; with-excursion-getter-and-setter <vars> proc
+;;;   <vars> is an unevaluated list of names that are bound in the caller.
+;;;   proc is called:
+;;;
+;;;		(proc excursion getter setter)
+;;;
+;;;   See also:
+;;;	with-getter-and-setter
+;;;	with-excursion-function
+;;;
+(defmacro with-excursion-getter-and-setter (vars proc)
+  `(,proc  ,(excursion-function-syntax vars)
+	  ,@ (getter-and-setter-syntax vars)))
+
+
+(define (excursion-function-syntax vars)
+  (let ((saved-value-names (map gensym vars))
+	(tmp-var-name (gensym "temp"))
+	(swap-fn-name (gensym "swap"))
+	(thunk-name (gensym "thunk")))
+    `(lambda (,thunk-name)
+       (letrec ((,tmp-var-name #f)
+		(,swap-fn-name
+		 (lambda () ,@ (map (lambda (n sn) 
+				      `(begin (set! ,tmp-var-name ,n)
+					      (set! ,n ,sn)
+					      (set! ,sn ,tmp-var-name)))
+				    vars saved-value-names)))
+		,@ (map (lambda (sn n) `(,sn ,n)) saved-value-names vars))
+	 (dynamic-wind
+	  ,swap-fn-name
+	  ,thunk-name
+	  ,swap-fn-name)))))
+
+
+(define (getter-and-setter-syntax vars)
+  (let ((args-name (gensym "args"))
+	(an-arg-name (gensym "an-arg"))
+	(new-val-name (gensym "new-value"))
+	(loop-name (gensym "loop"))
+	(kws (map symbol->keyword vars)))
+    (list `(lambda ,args-name
+	     (let ,loop-name ((,args-name ,args-name))
+		  (if (null? ,args-name)
+		      ,(if (null? kws)
+			   ''()
+			   `(let ((all-vals (,loop-name ',kws)))
+			      (let ,loop-name ((vals all-vals)
+					       (kws ',kws))
+				   (if (null? vals)
+				       '()
+				       `(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws)))))))
+		      (map (lambda (,an-arg-name)
+			     (case ,an-arg-name
+			       ,@ (append
+				   (map (lambda (kw v) `((,kw) ,v)) kws vars)
+				   `((else (throw 'bad-get-option ,an-arg-name))))))
+			   ,args-name))))
+
+	  `(lambda ,args-name
+	     (let ,loop-name ((,args-name ,args-name))
+		  (or (null? ,args-name)
+		      (null? (cdr ,args-name))
+		      (let ((,an-arg-name (car ,args-name))
+			    (,new-val-name (cadr ,args-name)))
+			(case ,an-arg-name
+			  ,@ (append
+			      (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars)
+			      `((else (throw 'bad-set-option ,an-arg-name)))))
+			(,loop-name (cddr ,args-name)))))))))
+
+(define (delegating-getter-and-setter-syntax  vars get-delegate set-delegate)
+  (let ((args-name (gensym "args"))
+	(an-arg-name (gensym "an-arg"))
+	(new-val-name (gensym "new-value"))
+	(loop-name (gensym "loop"))
+	(kws (map symbol->keyword vars)))
+    (list `(lambda ,args-name
+	     (let ,loop-name ((,args-name ,args-name))
+		  (if (null? ,args-name)
+		      (append!
+		       ,(if (null? kws)
+			    ''()
+			    `(let ((all-vals (,loop-name ',kws)))
+			       (let ,loop-name ((vals all-vals)
+						(kws ',kws))
+				    (if (null? vals)
+					'()
+					`(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws)))))))
+		       (,get-delegate))
+		      (map (lambda (,an-arg-name)
+			     (case ,an-arg-name
+			       ,@ (append
+				   (map (lambda (kw v) `((,kw) ,v)) kws vars)
+				   `((else (car (,get-delegate ,an-arg-name)))))))
+			   ,args-name))))
+
+	  `(lambda ,args-name
+	     (let ,loop-name ((,args-name ,args-name))
+		  (or (null? ,args-name)
+		      (null? (cdr ,args-name))
+		      (let ((,an-arg-name (car ,args-name))
+			    (,new-val-name (cadr ,args-name)))
+			(case ,an-arg-name
+			  ,@ (append
+			      (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars)
+			      `((else  (,set-delegate ,an-arg-name ,new-val-name)))))
+			(,loop-name (cddr ,args-name)))))))))
+
+
+
+
+;;; with-configuration-getter-and-setter <vars-etc> proc
+;;;
+;;;  Create a getter and setter that can trigger arbitrary computation.
+;;;
+;;;  <vars-etc> is a list of variable specifiers, explained below.
+;;;  proc is called:
+;;;
+;;;		(proc getter setter)
+;;;
+;;;   Each element of the <vars-etc> list is of the form:
+;;;
+;;;	(<var> getter-hook setter-hook)
+;;;
+;;;   Both hook elements are evaluated; the variable name is not.
+;;;   Either hook may be #f or procedure.
+;;;
+;;;   A getter hook is a thunk that returns a value for the corresponding
+;;;   variable.   If omitted (#f is passed), the binding of <var> is
+;;;   returned.
+;;;
+;;;   A setter hook is a procedure of one argument that accepts a new value
+;;;   for the corresponding variable.  If omitted, the binding of <var>
+;;;   is simply set using set!.
+;;;
+(defmacro with-configuration-getter-and-setter (vars-etc proc)
+  `((lambda (simpler-get simpler-set body-proc)
+      (with-delegating-getter-and-setter ()
+	simpler-get simpler-set body-proc))
+
+    (lambda (kw)
+      (case kw
+	,@(map (lambda (v) `((,(symbol->keyword (car v)))
+			     ,(cond
+			       ((cadr v)	=> list)
+			       (else		`(list ,(car v))))))
+	       vars-etc)))
+
+    (lambda (kw new-val)
+      (case kw
+	,@(map (lambda (v) `((,(symbol->keyword (car v)))
+			     ,(cond
+			       ((caddr v)	=> (lambda (proc) `(,proc new-val)))
+			       (else		`(set! ,(car v) new-val)))))
+	       vars-etc)))
+
+       ,proc))
+
+(defmacro with-delegating-configuration-getter-and-setter (vars-etc delegate-get delegate-set proc)
+  `((lambda (simpler-get simpler-set body-proc)
+      (with-delegating-getter-and-setter ()
+	simpler-get simpler-set body-proc))
+
+    (lambda (kw)
+      (case kw
+	,@(append! (map (lambda (v) `((,(symbol->keyword (car v)))
+				      ,(cond
+					((cadr v)	=> list)
+					(else		`(list ,(car v))))))
+			vars-etc)
+		   `((else (,delegate-get kw))))))
+
+    (lambda (kw new-val)
+      (case kw
+	,@(append! (map (lambda (v) `((,(symbol->keyword (car v)))
+				      ,(cond
+					((caddr v)	=> (lambda (proc) `(,proc new-val)))
+					(else		`(set! ,(car v) new-val)))))
+			vars-etc)
+		   `((else (,delegate-set kw new-val))))))
+
+    ,proc))
+
+
+;;; let-configuration-getter-and-setter <vars-etc> proc
+;;;
+;;;   This procedure is like with-configuration-getter-and-setter (q.v.)
+;;;   except that each element of <vars-etc> is:
+;;;
+;;;		(<var> initial-value getter-hook setter-hook)
+;;;
+;;;   Unlike with-configuration-getter-and-setter, let-configuration-getter-and-setter
+;;;   introduces bindings for the variables named in <vars-etc>.
+;;;   It is short-hand for:
+;;;
+;;;		(let ((<var1> initial-value-1)
+;;;		      (<var2> initial-value-2)
+;;;			...)
+;;;		  (with-configuration-getter-and-setter ((<var1> v1-get v1-set) ...) proc))
+;;;
+(defmacro let-with-configuration-getter-and-setter (vars-etc proc)
+  `(let ,(map (lambda (v) `(,(car v) ,(cadr v))) vars-etc)
+     (with-configuration-getter-and-setter ,(map (lambda (v) `(,(car v) ,(caddr v) ,(cadddr v))) vars-etc)
+					   ,proc)))

data/share/guile/2.2/ice-9/channel.scm

@@ -0,0 +1,170 @@
+;;; Guile object channel
+
+;; Copyright (C) 2001, 2006, 2009, 2010 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary:
+
+;; Now you can use Guile's modules in Emacs Lisp like this:
+;;
+;;   (guile-import current-module)
+;;   (guile-import module-ref)
+;;
+;;   (setq assq (module-ref (current-module) 'assq))
+;;     => ("<guile>" %%1%% . "#<primitive-procedure assq>")
+;;
+;;   (guile-use-modules (ice-9 documentation))
+;;
+;;   (object-documentation assq)
+;;     =>
+;;  " - primitive: assq key alist
+;;    - primitive: assv key alist
+;;    - primitive: assoc key alist
+;;        Fetches the entry in ALIST that is associated with KEY.  To decide
+;;        whether the argument KEY matches a particular entry in ALIST,
+;;        `assq' compares keys with `eq?', `assv' uses `eqv?' and `assoc'
+;;        uses `equal?'.  If KEY cannot be found in ALIST (according to
+;;        whichever equality predicate is in use), then `#f' is returned.
+;;        These functions return the entire alist entry found (i.e. both the
+;;        key and the value)."
+;;
+;; Probably we can use GTK in Emacs Lisp.  Can anybody try it?
+;;
+;; I have also implemented Guile Scheme mode and Scheme Interaction mode.
+;; Just put the following lines in your ~/.emacs:
+;;
+;;   (require 'guile-scheme)
+;;   (setq initial-major-mode 'scheme-interaction-mode)
+;;
+;; Currently, the following commands are available:
+;;
+;;   M-TAB    guile-scheme-complete-symbol
+;;   M-C-x    guile-scheme-eval-define
+;;   C-x C-e  guile-scheme-eval-last-sexp
+;;   C-c C-b  guile-scheme-eval-buffer
+;;   C-c C-r  guile-scheme-eval-region
+;;   C-c :    guile-scheme-eval-expression
+;;
+;; I'll write more commands soon, or if you want to hack, please take
+;; a look at the following files:
+;;
+;;   guile-core/ice-9/channel.scm       ;; object channel
+;;   guile-core/emacs/guile.el          ;; object adapter
+;;   guile-core/emacs/guile-emacs.scm   ;; Guile <-> Emacs channels
+;;   guile-core/emacs/guile-scheme.el   ;; Guile Scheme mode
+;;
+;; As always, there are more than one bugs ;)
+
+;;; Code:
+
+(define-module (ice-9 channel)
+  :export (make-object-channel
+	   channel-open
+	   channel-print-value
+	   channel-print-token))
+
+;;;
+;;; Channel type
+;;;
+
+(define channel-type
+  (make-record-type 'channel '(stdin stdout printer token-module)))
+
+(define make-channel (record-constructor channel-type))
+
+(define (make-object-channel printer)
+  (make-channel (current-input-port)
+		(current-output-port)
+		printer
+		(make-module)))
+
+(define channel-stdin (record-accessor channel-type 'stdin))
+(define channel-stdout (record-accessor channel-type 'stdout))
+(define channel-printer (record-accessor channel-type 'printer))
+(define channel-token-module (record-accessor channel-type 'token-module))
+
+;;;
+;;; Channel
+;;;
+
+(define (channel-open ch)
+  (let ((stdin (channel-stdin ch))
+	(stdout (channel-stdout ch))
+	(printer (channel-printer ch))
+	(token-module (channel-token-module ch)))
+    (let loop ()
+      (catch #t
+	(lambda ()
+	  (channel:prompt stdout)
+	  (let ((cmd (read stdin)))
+	    (if (eof-object? cmd)
+	      (throw 'quit)
+	      (case cmd
+		((eval)
+		 (module-use! (current-module) token-module)
+		 (printer ch (eval (read stdin) (current-module))))
+		((destroy)
+		 (let ((token (read stdin)))
+		   (if (module-defined? token-module token)
+		     (module-remove! token-module token)
+		     (channel:error stdout "Invalid token: ~S" token))))
+		((quit)
+		 (throw 'quit))
+		(else
+		 (channel:error stdout "Unknown command: ~S" cmd)))))
+	  (loop))
+	(lambda (key . args)
+	  (case key
+	    ((quit) (throw 'quit))
+	    (else
+	     (format stdout "exception = ~S\n"
+		     (list key (apply format #f (cadr args) (caddr args))))
+	     (loop))))))))
+
+(define (channel-print-value ch val)
+  (format (channel-stdout ch) "value = ~S\n" val))
+
+(define (channel-print-token ch val)
+  (let* ((token (symbol-append (gensym "%%") '%%))
+	 (pair (cons token (object->string val))))
+    (format (channel-stdout ch) "token = ~S\n" pair)
+    (module-define! (channel-token-module ch) token val)))
+
+(define (channel:prompt port)
+  (display "channel> " port)
+  (force-output port))
+
+(define (channel:error port msg . args)
+  (display "ERROR: " port)
+  (apply format port msg args)
+  (newline port))
+
+;;;
+;;; Guile 1.4 compatibility
+;;;
+
+(define guile:eval eval)
+(define eval
+  (if (= (car (procedure-minimum-arity guile:eval)) 1)
+    (lambda (x e) (guile:eval x e))
+    guile:eval))
+
+(define object->string
+  (if (defined? 'object->string)
+    object->string
+    (lambda (x) (format #f "~S" x))))
+
+;;; channel.scm ends here