LilyPond-Ruby 0.0.2.1 → 0.1.2

data/share/guile/2.2/system/xref.scm

@@ -0,0 +1,369 @@
+;;;; 	Copyright (C) 2009, 2010, 2013 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 (system xref)
+  #:use-module (system base compile)
+  #:use-module (system vm program)
+  #:use-module (system vm disassembler)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:export (*xref-ignored-modules*
+            procedure-callees
+            procedure-callers
+            source-closures
+            source-procedures))
+
+;;;
+;;; The cross-reference database: who calls whom.
+;;;
+
+(define (nested-procedures prog)
+  (define (cons-uniq x y)
+    (if (memq x y) y (cons x y)))
+  (if (program? prog)
+      (reverse
+       (fold-program-code (lambda (elt out)
+                            (match elt
+                              (('static-ref dst proc)
+                               (if (program? proc)
+                                   (fold cons-uniq
+                                         (cons proc out)
+                                         (nested-procedures prog))
+                                   out))
+                              (_ out)))
+                          (list prog)
+                          prog))
+      (list prog)))
+
+(define (program-callee-rev-vars prog)
+  (define (cons-uniq x y)
+    (if (memq x y) y (cons x y)))
+  (fold (lambda (prog out)
+          (fold-program-code
+           (lambda (elt out)
+             (match elt
+               (('toplevel-box dst var mod sym bound?)
+                (let ((var (or var (and mod (module-variable mod sym)))))
+                  (if var
+                      (cons-uniq var out)
+                      out)))
+               (('module-box dst var public? mod-name sym bound?)
+                (let ((var (or var
+                               (module-variable (if public?
+                                                    (resolve-interface mod-name)
+                                                    (resolve-module mod-name))
+                                                sym))))
+                  (if var
+                      (cons-uniq var out)
+                      out)))
+               (_ out)))
+           out
+           prog))
+        '()
+        (nested-procedures prog)))
+
+(define (procedure-callee-rev-vars proc)
+  (cond
+   ((program? proc) (program-callee-rev-vars proc))
+   (else '())))
+
+(define (procedure-callees prog)
+  "Evaluates to a list of the given program callees."
+  (let lp ((in (procedure-callee-rev-vars prog)) (out '()))
+    (cond ((null? in) out)
+          ((variable-bound? (car in))
+           (lp (cdr in) (cons (variable-ref (car in)) out)))
+          (else (lp (cdr in) out)))))
+
+;; var -> ((module-name caller ...) ...)
+(define *callers-db* #f)
+;; module-name -> (callee ...)
+(define *module-callees-db* (make-hash-table))
+;; (module-name ...)
+(define *tainted-modules* '())
+
+(define *xref-ignored-modules* '((value-history)))
+(define (on-module-modified m)
+  (let ((name (module-name m)))
+    (if (and (not (member name *xref-ignored-modules*))
+             (not (member name *tainted-modules*))
+             (pair? name))
+        (set! *tainted-modules* (cons name *tainted-modules*)))))
+
+(define (add-caller callee caller mod-name)
+  (let ((all-callers (hashq-ref *callers-db* callee)))
+    (if (not all-callers)
+        (hashq-set! *callers-db* callee `((,mod-name ,caller)))
+        (let ((callers (assoc mod-name all-callers)))
+          (if callers
+              (if (not (member caller callers))
+                  (set-cdr! callers (cons caller (cdr callers))))
+              (hashq-set! *callers-db* callee
+                          (cons `(,mod-name ,caller) all-callers)))))))
+
+(define (forget-callers callee mod-name)
+  (hashq-set! *callers-db* callee
+             (assoc-remove! (hashq-ref *callers-db* callee '()) mod-name)))
+
+(define (add-callees callees mod-name)
+  (hash-set! *module-callees-db* mod-name
+             (append callees (hash-ref *module-callees-db* mod-name '()))))
+
+(define (untaint-modules)
+  (define (untaint m)
+    (for-each (lambda (callee) (forget-callers callee m))
+              (hash-ref *module-callees-db* m '()))
+    (ensure-callers-db m))
+  (ensure-callers-db #f)
+  (for-each untaint *tainted-modules*)
+  (set! *tainted-modules* '()))
+
+(define (ensure-callers-db mod-name)
+  (let ((mod (and mod-name (resolve-module mod-name)))
+        (visited #f))
+    (define (visit-variable var mod-name)
+      (if (variable-bound? var)
+          (let ((x (variable-ref var)))
+            (cond
+             ((and visited (hashq-ref visited x)))
+             ((procedure? x)
+              (if visited (hashq-set! visited x #t))
+              (let ((callees (filter variable-bound?
+                                     (procedure-callee-rev-vars x))))
+                (for-each (lambda (callee)
+                            (add-caller callee x mod-name))
+                          callees)
+                (add-callees callees mod-name)))))))
+
+    (define (visit-module mod)
+      (if visited (hashq-set! visited mod #t))
+      (if (not (memq on-module-modified (module-observers mod)))
+          (module-observe mod on-module-modified))
+      (let ((name (module-name mod)))
+        (module-for-each (lambda (sym var)
+                           (visit-variable var name))
+                         mod)))
+
+    (define (visit-submodules mod)
+      (hash-for-each
+       (lambda (name sub)
+         (if (not (and visited (hashq-ref visited sub)))
+             (begin
+               (visit-module sub)
+               (visit-submodules sub))))
+       (module-submodules mod)))
+
+    (cond ((and (not mod-name) (not *callers-db*))
+           (set! *callers-db* (make-hash-table 1000))
+           (set! visited (make-hash-table 1000))
+           (visit-submodules (resolve-module '() #f)))
+          (mod-name (visit-module mod)))))
+
+(define (procedure-callers var)
+  "Returns an association list, keyed by module name, of known callers
+of the given procedure. The latter can specified directly as a
+variable, a symbol (which gets resolved in the current module) or a
+pair of the form (module-name . variable-name), "
+  (let ((v (cond ((variable? var) var)
+                 ((symbol? var) (module-variable (current-module) var))
+                 (else
+                  (match var
+                    ((modname . sym)
+                     (module-variable (resolve-module modname) sym))
+                    (_
+                     (error "expected a variable, symbol, or (modname . sym)" var)))))))
+    (untaint-modules)
+    (hashq-ref *callers-db* v '())))
+
+
+
+;;;
+;;; The source database: procedures defined at a given source location.
+;;;
+
+;; FIXME: refactor to share code with the xref database.
+
+;; ((ip file line . col) ...)
+(define (procedure-sources proc)
+  (cond
+   ((program? proc) (program-sources proc))
+   (else '())))
+
+;; file -> line -> (proc ...)
+(define *closure-sources-db* #f)
+;; file -> line -> (proc ...)
+(define *sources-db* #f)
+;; module-name -> proc -> sources
+(define *module-sources-db* (make-hash-table))
+;; (module-name ...)
+(define *tainted-sources* '())
+
+(define (on-source-modified m)
+  (let ((name (module-name m)))
+    (if (and (not (member name *xref-ignored-modules*))
+             (not (member name *tainted-sources*))
+             (pair? name))
+        (set! *tainted-sources* (cons name *tainted-sources*)))))
+
+(define (add-source proc file line db)
+  (let ((file-table (or (hash-ref db file)
+                        (let ((table (make-hash-table)))
+                          (hash-set! db file table)
+                          table))))
+    (hashv-set! file-table
+                line
+                (cons proc (hashv-ref file-table line '())))))
+
+(define (forget-source proc file line db)
+  (let ((file-table (hash-ref db file)))
+    (if file-table
+        (let ((procs (delq proc (hashv-ref file-table line '()))))
+          (if (pair? procs)
+              (hashv-set! file-table line procs)
+              (hashv-remove! file-table line))))))
+
+(define (add-sources proc mod-name db)
+  (let ((sources (procedure-sources proc)))
+    (if (pair? sources)
+        (begin
+          ;; Add proc to *module-sources-db*, for book-keeping.
+          (hashq-set! (or (hash-ref *module-sources-db* mod-name)
+                          (let ((table (make-hash-table)))
+                            (hash-set! *module-sources-db* mod-name table)
+                            table))
+                      proc
+                      sources)
+          ;; Actually add the source entries.
+          (for-each (lambda (source)
+                      (match source
+                        ((ip file line . col)
+                         (add-source proc file line db))
+                        (_ (error "unexpected source format" source))))
+                    sources)))
+    ;; Add source entries for nested procedures.
+    (for-each (lambda (obj)
+                (add-sources obj mod-name *closure-sources-db*))
+              (cdr (nested-procedures proc)))))
+
+(define (forget-sources proc mod-name db)
+  (let ((mod-table (hash-ref *module-sources-db* mod-name)))
+    (when mod-table
+      ;; Forget source entries.
+      (for-each (lambda (source)
+                  (match source
+                    ((ip file line . col)
+                     (forget-source proc file line db))
+                    (_ (error "unexpected source format" source))))
+                (hashq-ref mod-table proc '()))
+      ;; Forget the proc.
+      (hashq-remove! mod-table proc)
+      ;; Forget source entries for nested procedures.
+      (for-each (lambda (obj)
+                  (forget-sources obj mod-name *closure-sources-db*))
+                (cdr (nested-procedures proc))))))
+
+(define (untaint-sources)
+  (define (untaint m)
+    (for-each (lambda (proc) (forget-sources proc m *sources-db*))
+              (cond
+               ((hash-ref *module-sources-db* m)
+                => (lambda (table)
+                     (hash-for-each (lambda (proc sources) proc) table)))
+               (else '())))
+    (ensure-sources-db m))
+  (ensure-sources-db #f)
+  (for-each untaint *tainted-sources*)
+  (set! *tainted-sources* '()))
+
+(define (ensure-sources-db mod-name)
+  (define (visit-module mod)
+    (if (not (memq on-source-modified (module-observers mod)))
+        (module-observe mod on-source-modified))
+    (let ((name (module-name mod)))
+      (module-for-each
+       (lambda (sym var)
+         (if (variable-bound? var)
+             (let ((x (variable-ref var)))
+               (if (procedure? x)
+                   (add-sources x name *sources-db*)))))
+       mod)))
+
+  (define visit-submodules
+    (let ((visited #f))
+      (lambda (mod)
+        (if (not visited)
+            (set! visited (make-hash-table)))
+        (hash-for-each
+         (lambda (name sub)
+           (if (not (hashq-ref visited sub))
+               (begin
+                 (hashq-set! visited sub #t)
+                 (visit-module sub)
+                 (visit-submodules sub))))
+         (module-submodules mod)))))
+
+  (cond ((and (not mod-name) (not *sources-db*) (not *closure-sources-db*))
+         (set! *closure-sources-db* (make-hash-table 1000))
+         (set! *sources-db* (make-hash-table 1000))
+         (visit-submodules (resolve-module '() #f)))
+        (mod-name (visit-module (resolve-module mod-name)))))
+
+(define (lines->ranges file-table)
+  (let ((ranges (make-hash-table)))
+    (hash-for-each
+     (lambda (line procs)
+       (for-each
+        (lambda (proc)
+          (cond
+           ((hashq-ref ranges proc)
+            => (lambda (pair)
+                 (if (< line (car pair))
+                     (set-car! pair line))
+                 (if (> line (cdr pair))
+                     (set-cdr! pair line))))
+           (else
+            (hashq-set! ranges proc (cons line line)))))
+        procs))
+     file-table)
+    (sort! (hash-map->list cons ranges)
+           (lambda (x y) (< (cadr x) (cadr y))))))
+
+(define* (lookup-source-procedures canon-file line db)
+  (let ((file-table (hash-ref db canon-file)))
+    (let lp ((ranges (if file-table (lines->ranges file-table) '()))
+             (procs '()))
+      (cond
+       ((null? ranges) (reverse procs))
+       ((<= (cadar ranges) line (cddar ranges))
+        (lp (cdr ranges) (cons (caar ranges) procs)))
+       (else
+        (lp (cdr ranges) procs))))))
+
+(define* (source-closures file line #:key (canonicalization 'relative))
+  (ensure-sources-db #f)
+  (let* ((port (with-fluids ((%file-port-name-canonicalization canonicalization))
+                 (false-if-exception (open-input-file file))))
+         (file (if port (port-filename port) file)))
+    (lookup-source-procedures file line *closure-sources-db*)))
+
+(define* (source-procedures file line #:key (canonicalization 'relative))
+  (ensure-sources-db #f)
+  (let* ((port (with-fluids ((%file-port-name-canonicalization canonicalization))
+                 (false-if-exception (open-input-file file))))
+         (file (if port (port-filename port) file)))
+    (lookup-source-procedures file line *sources-db*)))

data/share/guile/2.2/texinfo/docbook.scm

@@ -0,0 +1,240 @@
+;;;; (texinfo docbook) -- translating sdocbook into stexinfo
+;;;;
+;;;; 	Copyright (C) 2009, 2010, 2012  Free Software Foundation, Inc.
+;;;;    Copyright (C) 2007, 2009 Andy Wingo <wingo at pobox dot com>
+;;;; 
+;;;; 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:
+;;
+;; @c
+;; This module exports procedures for transforming a limited subset of
+;; the SXML representation of docbook into stexi. It is not complete by
+;; any means. The intention is to gather a number of routines and
+;; stylesheets so that external modules can parse specific subsets of
+;; docbook, for example that set generated by certain tools.
+;;
+;;; Code:
+
+(define-module (texinfo docbook)
+  #:use-module (sxml fold)
+  #:use-module ((srfi srfi-1) #:select (fold))
+  #:export (*sdocbook->stexi-rules*
+            *sdocbook-block-commands*
+            sdocbook-flatten
+            filter-empty-elements
+            replace-titles))
+
+(define (identity . args)
+  args)
+
+(define (identity-deattr tag . body)
+  `(,tag ,@(if (and (pair? body) (pair? (car body))
+                    (eq? (caar body) '@))
+               (cdr body)
+               body)))
+
+(define (detag-one tag body)
+  body)
+
+(define tag-replacements
+  '((parameter var)
+    (replaceable var)
+    (type code)
+    (function code)
+    (literal samp)
+    (emphasis emph)
+    (simpara para)
+    (programlisting example)
+    (firstterm dfn)
+    (filename file)
+    (quote cite)
+    (application cite)
+    (symbol code)
+    (note cartouche)
+    (envar env)))
+
+(define ignore-list '())
+
+(define (stringify exp)
+  (with-output-to-string (lambda () (write exp))))
+
+(define *sdocbook->stexi-rules*
+  #;
+  "A stylesheet for use with SSAX's @code{pre-post-order}, which defines
+a number of generic rules for transforming docbook into texinfo."
+  `((@ *preorder* . ,identity)
+    (% *preorder* . ,identity)
+    (para . ,identity-deattr)
+    (orderedlist ((listitem
+                   . ,(lambda (tag . body)
+                        `(item ,@body))))
+                 . ,(lambda (tag . body)
+                      `(enumerate ,@body)))
+    (itemizedlist ((listitem
+                    . ,(lambda (tag . body)
+                         `(item ,@body))))
+                  . ,(lambda (tag . body)
+                       `(itemize ,@body)))
+    (acronym . ,(lambda (tag . body)
+                  `(acronym (% (acronym . ,body)))))
+    (term . ,detag-one)
+    (informalexample . ,detag-one)
+    (section . ,identity)
+    (subsection . ,identity)
+    (subsubsection . ,identity)
+    (ulink . ,(lambda (tag attrs . body)
+                (cond
+                 ((assq 'url (cdr attrs))
+                  => (lambda (url)
+                       `(uref (% ,url (title ,@body)))))
+                 (else
+                  (car body)))))
+    (*text* . ,detag-one)
+    (*default* . ,(lambda (tag . body)
+                    (let ((subst (assq tag tag-replacements)))
+                      (cond
+                       (subst
+                        (if (and (pair? body) (pair? (car body)) (eq? (caar body) '@))
+                            (begin
+                              (warn "Ignoring" tag "attributes" (car body))
+                              (append (cdr subst) (cdr body)))
+                            (append (cdr subst) body)))
+                       ((memq tag ignore-list) #f)
+                       (else 
+                        (warn "Don't know how to convert" tag "to stexi")
+                        `(c (% (all ,(stringify (cons tag body))))))))))))
+
+;;     (variablelist
+;;      ((varlistentry
+;;        . ,(lambda (tag term . body)
+;;             `(entry (% (heading ,@(cdr term))) ,@body)))
+;;       (listitem
+;;        . ,(lambda (tag simpara)
+;;             simpara)))
+;;      . ,(lambda (tag attrs . body)
+;;           `(table (% (formatter (var))) ,@body)))
+
+(define *sdocbook-block-commands*
+  #;
+  "The set of sdocbook element tags that should not be nested inside
+each other. @xref{texinfo docbook sdocbook-flatten,,sdocbook-flatten},
+for more information." 
+  '(para programlisting informalexample indexterm variablelist
+    orderedlist refsect1 refsect2 refsect3 refsect4 title example
+    note itemizedlist informaltable))
+
+(define (inline-command? command)
+  (not (memq command *sdocbook-block-commands*)))
+
+(define (sdocbook-flatten sdocbook)
+  "\"Flatten\" a fragment of sdocbook so that block elements do not nest
+inside each other.
+
+Docbook is a nested format, where e.g. a @code{refsect2} normally
+appears inside a @code{refsect1}. Logical divisions in the document are
+represented via the tree topology; a @code{refsect2} element
+@emph{contains} all of the elements in its section.
+
+On the contrary, texinfo is a flat format, in which sections are marked
+off by standalone section headers like @code{@@chapter}, and block
+elements do not nest inside each other.
+
+This function takes a nested sdocbook fragment @var{sdocbook} and
+flattens all of the sections, such that e.g.
+@example
+ (refsect1 (refsect2 (para \"Hello\")))
+@end example
+becomes
+@example
+ ((refsect1) (refsect2) (para \"Hello\"))
+@end example
+
+Oftentimes (always?) sectioning elements have @code{<title>} as their
+first element child; users interested in processing the @code{refsect*}
+elements into proper sectioning elements like @code{chapter} might be
+interested in @code{replace-titles} and @code{filter-empty-elements}.
+@xref{texinfo docbook replace-titles,,replace-titles}, and @ref{texinfo
+docbook filter-empty-elements,,filter-empty-elements}.
+
+Returns a nodeset, as described in @ref{sxml xpath}. That is to say,
+this function returns an untagged list of stexi elements."
+  (define (fhere str accum block cont)
+    (values (cons str accum)
+            block
+            cont))
+  (define (fdown node accum block cont)
+    (let ((command (car node))
+          (attrs (and (pair? (cdr node)) (pair? (cadr node))
+                      (eq? (caadr node) '%)
+                      (cadr node))))
+      (values (if attrs (cddr node) (cdr node))
+              '()
+              '()
+              (lambda (accum block)
+                (values
+                 `(,command ,@(if attrs (list attrs) '())
+                            ,@(reverse accum))
+                 block)))))
+  (define (fup node paccum pblock pcont kaccum kblock kcont)
+    (call-with-values (lambda () (kcont kaccum kblock))
+      (lambda (ret block)
+        (if (inline-command? (car ret))
+            (values (cons ret paccum) (append kblock pblock) pcont)
+            (values paccum (append kblock (cons ret pblock)) pcont)))))
+  (call-with-values
+      (lambda () (foldts*-values fdown fup fhere sdocbook '() '() #f))
+    (lambda (accum block cont)
+      (reverse block))))
+    
+(define (filter-empty-elements sdocbook)
+  "Filters out empty elements in an sdocbook nodeset. Mostly useful
+after running @code{sdocbook-flatten}."
+  (reverse
+   (fold
+    (lambda (x rest)
+      (if (and (pair? x) (null? (cdr x)))
+          rest
+          (cons x rest)))
+    '()
+    sdocbook)))
+
+(define (replace-titles sdocbook-fragment)
+  "Iterate over the sdocbook nodeset @var{sdocbook-fragment},
+transforming contiguous @code{refsect} and @code{title} elements into
+the appropriate texinfo sectioning command. Most useful after having run
+@code{sdocbook-flatten}.
+
+For example:
+@example
+ (replace-titles '((refsect1) (title \"Foo\") (para \"Bar.\")))
+    @result{} '((chapter \"Foo\") (para \"Bar.\"))
+@end example
+"
+  (define sections '((refsect1 . chapter)
+                     (refsect2 . section)
+                     (refsect3 . subsection)
+                     (refsect4 . subsubsection)))
+  (let lp ((in sdocbook-fragment) (out '()))
+    (cond
+     ((null? in)
+      (reverse out))
+     ((and (pair? (car in)) (assq (caar in) sections))
+      ;; pull out the title
+      => (lambda (pair)
+           (lp (cddr in) (cons `(,(cdr pair) ,@(cdadr in)) out))))
+     (else
+      (lp (cdr in) (cons (car in) out))))))