X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=guile18%2Fscripts%2Fsnarf-check-and-output-texi;fp=guile18%2Fscripts%2Fsnarf-check-and-output-texi;h=8cd42e860e6a38972ffa0097bba09d375be01366;hb=139c38d9204dd07f6b235f83bae644faedbc63fd;hp=0000000000000000000000000000000000000000;hpb=652ed35a2013489d0a14fede6307cd2595abb2c4;p=lilypond.git

diff --git a/guile18/scripts/snarf-check-and-output-texi b/guile18/scripts/snarf-check-and-output-texi
new file mode 100755
index 0000000000..8cd42e860e
--- /dev/null
+++ b/guile18/scripts/snarf-check-and-output-texi
@@ -0,0 +1,324 @@
+#!/bin/sh
+# aside from this initial boilerplate, this is actually -*- scheme -*- code
+main="(module-ref (resolve-module '(scripts snarf-check-and-output-texi)) 'main)"
+exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
+!#
+;;; snarf-check-and-output-texi --- called by the doc snarfer.
+
+;; 	Copyright (C) 2001, 2002, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or
+;; (at your option) any later version.
+;;
+;; This program 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
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this software; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301 USA
+
+;;; Author: Michael Livshin
+
+;;; Code:
+
+(define-module (scripts snarf-check-and-output-texi)
+    :use-module (ice-9 streams)
+    :use-module (ice-9 match)
+    :export (snarf-check-and-output-texi))
+
+;;; why aren't these in some module?
+
+(define-macro (when cond . body)
+  `(if ,cond (begin ,@body)))
+
+(define-macro (unless cond . body)
+  `(if (not ,cond) (begin ,@body)))
+
+(define *manual-flag* #f)
+
+(define (snarf-check-and-output-texi . flags)
+  (if (member "--manual" flags)
+      (set! *manual-flag* #t))
+  (process-stream (current-input-port)))
+
+(define (process-stream port)
+  (let loop ((input (stream-map (match-lambda
+                                 (('id . s)
+                                  (cons 'id (string->symbol s)))
+                                 (('int_dec . s)
+                                  (cons 'int (string->number s)))
+                                 (('int_oct . s)
+                                  (cons 'int (string->number s 8)))
+                                 (('int_hex . s)
+                                  (cons 'int (string->number s 16)))
+                                 ((and x (? symbol?))
+                                  (cons x x))
+                                 ((and x (? string?))
+                                  (cons 'string x))
+                                 (x x))
+                                (make-stream (lambda (s)
+                                               (let loop ((s s))
+                                                 (cond
+                                                   ((stream-null? s) #t)
+                                                   ((eq? 'eol (stream-car s))
+                                                    (loop (stream-cdr s)))
+                                                   (else (cons (stream-car s) (stream-cdr s))))))
+                                             (port->stream port read)))))
+
+    (unless (stream-null? input)
+      (let ((token (stream-car input)))
+        (if (eq? (car token) 'snarf_cookie)
+          (dispatch-top-cookie (stream-cdr input)
+                               loop)
+          (loop (stream-cdr input)))))))
+
+(define (dispatch-top-cookie input cont)
+
+  (when (stream-null? input)
+    (error 'syntax "premature end of file"))
+
+  (let ((token (stream-car input)))
+    (cond
+      ((eq? (car token) 'brace_open)
+       (consume-multiline (stream-cdr input)
+                          cont))
+      (else
+       (consume-upto-cookie process-singleline
+                            input
+                            cont)))))
+
+(define (consume-upto-cookie process input cont)
+  (let loop ((acc '()) (input input))
+
+    (when (stream-null? input)
+      (error 'syntax "premature end of file in directive context"))
+
+    (let ((token (stream-car input)))
+      (cond
+        ((eq? (car token) 'snarf_cookie)
+         (process (reverse! acc))
+         (cont (stream-cdr input)))
+
+        (else (loop (cons token acc) (stream-cdr input)))))))
+
+(define (consume-multiline input cont)
+  (begin-multiline)
+
+  (let loop ((input input))
+
+    (when (stream-null? input)
+      (error 'syntax "premature end of file in multiline context"))
+
+    (let ((token (stream-car input)))
+      (cond
+        ((eq? (car token) 'brace_close)
+         (end-multiline)
+         (cont (stream-cdr input)))
+
+        (else (consume-upto-cookie process-multiline-directive
+                                   input
+                                   loop))))))
+
+(define *file* #f)
+(define *line* #f)
+(define *c-function-name* #f)
+(define *function-name* #f)
+(define *snarf-type* #f)
+(define *args* #f)
+(define *sig* #f)
+(define *docstring* #f)
+
+(define (begin-multiline)
+  (set! *file* #f)
+  (set! *line* #f)
+  (set! *c-function-name* #f)
+  (set! *function-name* #f)
+  (set! *snarf-type* #f)
+  (set! *args* #f)
+  (set! *sig* #f)
+  (set! *docstring* #f))
+
+(define *primitive-deffnx-signature* "@deffnx {Scheme Procedure} ")
+(define *primitive-deffnx-sig-length* (string-length *primitive-deffnx-signature*))
+
+(define (end-multiline)
+  (let* ((req (car *sig*))
+         (opt (cadr *sig*))
+         (var (caddr *sig*))
+         (all (+ req opt var)))
+    (if (and (not (eqv? *snarf-type* 'register))
+             (not (= (length *args*) all)))
+      (error (format #f "~A:~A: ~A's C implementation takes ~A args (should take ~A)"
+             *file* *line* *function-name* (length *args*) all)))
+    (let ((nice-sig
+            (if (eq? *snarf-type* 'register)
+              *function-name*
+              (with-output-to-string
+                (lambda ()
+                  (format #t "~A" *function-name*)
+                  (let loop-req ((args *args*) (r 0))
+                    (if (< r req)
+                      (begin
+                       (format #t " ~A" (car args))
+                       (loop-req (cdr args) (+ 1 r)))
+                      (let loop-opt ((o 0) (args args) (tail '()))
+                       (if (< o opt)
+                         (begin
+                          (format #t " [~A" (car args))
+                          (loop-opt (+ 1 o) (cdr args) (cons #\] tail)))
+                         (begin
+                          (if (> var 0)
+                            (format #t " . ~A"
+                                    (car args)))
+                          (let loop-tail ((tail tail))
+                               (if (not (null? tail))
+                                 (begin
+                                  (format #t "~A" (car tail))
+                                  (loop-tail (cdr tail))))))))))))))
+	  (scm-deffnx
+	    (if (and *manual-flag* (eq? *snarf-type* 'primitive))
+		(with-output-to-string
+		  (lambda ()
+                    (format #t "@deffnx {C Function} ~A (" *c-function-name*)
+		    (unless (null? *args*)
+		      (format #t "~A" (car *args*))
+		      (let loop ((args (cdr *args*)))
+			(unless (null? args)
+			  (format #t ", ~A" (car args))
+			  (loop (cdr args)))))
+		    (format #t ")\n")))
+		#f)))
+      (format #t "\n~A\n" *function-name*)
+      (format #t "@c snarfed from ~A:~A\n" *file* *line*)
+      (format #t "@deffn {Scheme Procedure} ~A\n" nice-sig)
+      (let loop ((strings *docstring*) (scm-deffnx scm-deffnx))
+	(cond ((null? strings))
+	      ((or (not scm-deffnx)
+		   (and (>= (string-length (car strings))
+			    *primitive-deffnx-sig-length*)
+			(string=? (substring (car strings)
+					     0 *primitive-deffnx-sig-length*)
+				  *primitive-deffnx-signature*)))
+	       (display (car strings))
+	       (loop (cdr strings) scm-deffnx))
+	      (else (display scm-deffnx)
+		    (loop strings #f))))
+      (display "\n")
+      (display "@end deffn\n"))))
+
+(define (texi-quote s)
+  (let rec ((i 0))
+    (if (= i (string-length s))
+      ""
+      (string-append (let ((ss (substring s i (+ i 1))))
+                       (if (string=? ss "@")
+                         "@@"
+                         ss))
+                     (rec (+ i 1))))))
+
+(define (process-multiline-directive l)
+
+  (define do-args
+    (match-lambda
+
+     (('(paren_close . paren_close))
+      '())
+
+     (('(comma . comma) rest ...)
+      (do-args rest))
+
+     (('(id . SCM) ('id . name) rest ...)
+      (cons name (do-args rest)))
+
+     (x (error (format #f "invalid argument syntax: ~A" (map cdr x))))))
+
+  (define do-arglist
+    (match-lambda
+
+     (('(paren_open . paren_open) '(id . void) '(paren_close . paren_close))
+      '())
+
+     (('(paren_open . paren_open) rest ...)
+      (do-args rest))
+
+     (x (error (format #f "invalid arglist syntax: ~A" (map cdr x))))))
+
+  (define do-command
+    (match-lambda
+
+     (('cname ('id . name))
+      (set! *c-function-name* (texi-quote (symbol->string name))))
+
+     (('fname ('string . name) ...)
+      (set! *function-name* (texi-quote (apply string-append name))))
+
+     (('type ('id . type))
+      (set! *snarf-type* type))
+
+     (('type ('int . num))
+      (set! *snarf-type* num))
+
+     (('location ('string . file) ('int . line))
+      (set! *file* file)
+      (set! *line* line))
+
+     ;; newer gccs like to throw around more location markers into the
+     ;; preprocessed source; these (hash . hash) bits are what they translate to
+     ;; in snarfy terms.
+     (('location ('string . file) ('int . line) ('hash . 'hash))
+      (set! *file* file)
+      (set! *line* line))
+
+     (('location ('hash . 'hash) ('string . file) ('int . line) ('hash . 'hash))
+      (set! *file* file)
+      (set! *line* line))
+
+     (('arglist rest ...)
+      (set! *args* (do-arglist rest)))
+
+     (('argsig ('int . req) ('int . opt) ('int . var))
+      (set! *sig* (list req opt var)))
+
+     (x (error (format #f "unknown doc attribute: ~A" x)))))
+
+  (define do-directive
+    (match-lambda
+
+     ((('id . command) rest ...)
+      (do-command (cons command rest)))
+
+     ((('string . string) ...)
+      (set! *docstring* string))
+
+     (x (error (format #f "unknown doc attribute syntax: ~A" x)))))
+
+  (do-directive l))
+
+(define (process-singleline l)
+
+  (define do-argpos
+    (match-lambda
+     ((('id . name) ('int . pos) ('int . line))
+      (let ((idx (list-index *args* name)))
+        (when idx
+          (unless (= (+ idx 1) pos)
+            (display (format #f "~A:~A: wrong position for argument ~A: ~A (should be ~A)\n"
+                             *file* line name pos (+ idx 1))
+                     (current-error-port))))))
+     (x #f)))
+
+  (define do-command
+    (match-lambda
+     (('(id . argpos) rest ...)
+      (do-argpos rest))
+     (x (error (format #f "unknown check: ~A" x)))))
+
+  (when *function-name*
+    (do-command l)))
+
+(define main snarf-check-and-output-texi)