From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Sun, 4 Aug 2019 23:22:10 +0000 (-0700)
Subject: Plugin builds: Improved tags-fix.sh.  Handle .cdecl files specially.
X-Git-Tag: mit-scheme-pucked-10.1.20~21^2~1
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b19dc2c96f4ff5bbe4ce8c8a4616d8dbe08b2c11;p=mit-scheme.git

Plugin builds: Improved tags-fix.sh.  Handle .cdecl files specially.
---

diff --git a/src/blowfish/Makefile.am b/src/blowfish/Makefile.am
index e09a52af6..7a6970b4b 100644
--- a/src/blowfish/Makefile.am
+++ b/src/blowfish/Makefile.am
@@ -88,10 +88,9 @@ CLEANFILES += @MIT_SCHEME_CLEAN@
 TESTS = blowfish-check.sh
 CLEANFILES += test
 
-tags: tags-am
-	./tags-fix.sh blowfish
-
-TAGS_FILES = $(sources) blowfish-adapter.c $(cdecls)
+tags: tags-am $(sources) $(cdecls)
+	$(ETAGS) -a $(sources) -r '/^([^iI].*/' $(cdecls)
+	./tags-fix.sh
 
 EXTRA_DIST += $(sources) $(cdecls)
 EXTRA_DIST += compile.sh compile.scm blowfish.pkg
diff --git a/src/blowfish/tags-fix.sh b/src/blowfish/tags-fix.sh
index a22e6bab5..6fda030bf 100755
--- a/src/blowfish/tags-fix.sh
+++ b/src/blowfish/tags-fix.sh
@@ -1,42 +1,89 @@
 #!/bin/sh
 # -*-Scheme-*-
 #
-# Chop the generated $1-shim.c and $1-const.c files out of TAGS.
+# Changes to TAGS:
+#   + Punt any generated *-shim.c and *-const.c files.
+#   + Re-order the files: .scm first, .[hc] next, whatnot, and .cdecls last.
 
 set -e
 : ${MIT_SCHEME_EXE=mit-scheme}
 ${MIT_SCHEME_EXE} --batch-mode -- ${1+"$@"} <<\EOF
-(let ((name (car (command-line-arguments))))
-  (let ((shim.c-prefix (string-append name "-shim.c,"))
-	(const.c-prefix (string-append name "-const.c,")))
-
-    (define (rewriter in out)
-      (let loop ((skipping? #f))
-	(let ((line (read-line in)))
-	  (cond ((eof-object? line)
-		 unspecific)
-		((string=? line "\f")
-		 (let ((next (read-line in)))
-		   (cond ((eof-object? next) (error "Bogus TAGS format:" next))
-			 ((or (string-prefix? shim.c-prefix next)
-			      (string-prefix? const.c-prefix next))
-			  (loop #t))
-			 (else
-			  (write-string line out)
-			  (newline out)
-			  (write-string next out)
-			  (newline out)
-			  (loop #f)))))
-		(skipping?
-		 (loop skipping?))
-		(else
-		 (write-string line out)
-		 (newline out)
-		 (loop skipping?))))))
-
-    (parameterize ((param:suppress-loading-message? #t))
-      (load-option 'FFI))
-    ((access rewrite-file (->environment '(ffi build)))
-     (merge-pathnames "TAGS")
-     rewriter)))
+(let ()
+
+  (define-integrable (make-section filename bytecount lines)
+    (cons (cons filename bytecount) lines))
+  (define-integrable section.filename caar)
+  (define-integrable section.bytecount cdar)
+  (define-integrable section.lines cdr)
+
+  (define headline-pattern
+    (compile-regsexp '(seq (line-start)
+			   (group filename (+ (char-not-in #\,)))
+			   #\,
+			   (group bytecount (+ (char-in numeric)))
+			   (line-end))))
+
+  (define (write-section section out)
+    (write-string "\f\n" out)
+    (write-string (string (section.filename section)
+			  #\, (section.bytecount section)
+			  "\n")
+		  out)
+    (for-each (lambda (line) (write-string line out) (newline out))
+	      (section.lines section)))
+
+  (define (write-sections sections out)
+    (for-each (lambda (section) (write-section section out))
+	      (sort sections
+		    (lambda (a b)
+		      (string<? (section.filename a)
+				(section.filename b))))))
+
+  (define (read-section in)
+    (let loop ((lines '()))
+      (let ((line (read-line in)))
+	(if (or (eof-object? line)
+		(string=? line "\f"))
+	    (reverse! lines)
+	    (loop (cons line lines))))))
+
+  (define (rewriter in out)
+    (let ((line (read-line in)))
+      (cond ((eof-object? line)
+	     (error "TAGS file is empty"))
+	    ((not (string=? line "\f"))
+	     (error "TAGS file does not start with a formfeed:" line))))
+    (let loop ((scms '()) (chs '()) (cdecls '()) (rest '()))
+      (let ((line (read-line in)))
+	(if (eof-object? line)
+	    (begin
+	      (write-sections scms out)
+	      (write-sections chs out)
+	      (write-sections rest out)
+	      (write-sections cdecls out))
+	    (let ((match (regsexp-match-string headline-pattern line)))
+	      (if (not match)
+		  (error "TAGS file contains a bogus headline:" line))
+	      (let ((filename (cdr (assq 'filename (cddr match))))
+		    (section (make-section (cdr (assq 'filename (cddr match)))
+					   (cdr (assq 'bytecount (cddr match)))
+					   (read-section in))))
+		(cond ((or (string-suffix? "-shim.c" filename)
+			   (string-suffix? "-const.c" filename))
+		       (loop scms chs cdecls rest))
+		      ((string-suffix? ".scm" filename)
+		       (loop (cons section scms) chs cdecls rest))
+		      ((or (string-suffix? ".c" filename)
+			   (string-suffix? ".h" filename))
+		       (loop scms (cons section chs) cdecls rest))
+		      ((string-suffix? ".cdecl" filename)
+		       (loop scms chs (cons section cdecls) rest))
+		      (else
+		       (loop scms chs cdecls (cons section rest))))))))))
+
+  (parameterize ((param:suppress-loading-message? #t))
+    (load-option 'ffi))
+  ((access rewrite-file (->environment '(ffi build)))
+   (merge-pathnames "TAGS")
+   rewriter))
 EOF
diff --git a/src/gdbm/Makefile.am b/src/gdbm/Makefile.am
index b7cc901cf..075a1824a 100644
--- a/src/gdbm/Makefile.am
+++ b/src/gdbm/Makefile.am
@@ -88,10 +88,9 @@ CLEANFILES += @MIT_SCHEME_CLEAN@
 TESTS = gdbm-check.sh
 CLEANFILES += gdbm-check.db
 
-tags: tags-am
-	./tags-fix.sh gdbm
-
-TAGS_FILES = $(sources) gdbm-adapter.c $(cdecls)
+tags: tags-am $(sources) $(cdecls)
+	$(ETAGS) -a $(sources) -r '/^([^iI].*/' $(cdecls)
+	./tags-fix.sh
 
 EXTRA_DIST += $(sources) $(cdecls)
 EXTRA_DIST += compile.sh compile.scm gdbm.pkg
diff --git a/src/gdbm/tags-fix.sh b/src/gdbm/tags-fix.sh
index a22e6bab5..6fda030bf 100755
--- a/src/gdbm/tags-fix.sh
+++ b/src/gdbm/tags-fix.sh
@@ -1,42 +1,89 @@
 #!/bin/sh
 # -*-Scheme-*-
 #
-# Chop the generated $1-shim.c and $1-const.c files out of TAGS.
+# Changes to TAGS:
+#   + Punt any generated *-shim.c and *-const.c files.
+#   + Re-order the files: .scm first, .[hc] next, whatnot, and .cdecls last.
 
 set -e
 : ${MIT_SCHEME_EXE=mit-scheme}
 ${MIT_SCHEME_EXE} --batch-mode -- ${1+"$@"} <<\EOF
-(let ((name (car (command-line-arguments))))
-  (let ((shim.c-prefix (string-append name "-shim.c,"))
-	(const.c-prefix (string-append name "-const.c,")))
-
-    (define (rewriter in out)
-      (let loop ((skipping? #f))
-	(let ((line (read-line in)))
-	  (cond ((eof-object? line)
-		 unspecific)
-		((string=? line "\f")
-		 (let ((next (read-line in)))
-		   (cond ((eof-object? next) (error "Bogus TAGS format:" next))
-			 ((or (string-prefix? shim.c-prefix next)
-			      (string-prefix? const.c-prefix next))
-			  (loop #t))
-			 (else
-			  (write-string line out)
-			  (newline out)
-			  (write-string next out)
-			  (newline out)
-			  (loop #f)))))
-		(skipping?
-		 (loop skipping?))
-		(else
-		 (write-string line out)
-		 (newline out)
-		 (loop skipping?))))))
-
-    (parameterize ((param:suppress-loading-message? #t))
-      (load-option 'FFI))
-    ((access rewrite-file (->environment '(ffi build)))
-     (merge-pathnames "TAGS")
-     rewriter)))
+(let ()
+
+  (define-integrable (make-section filename bytecount lines)
+    (cons (cons filename bytecount) lines))
+  (define-integrable section.filename caar)
+  (define-integrable section.bytecount cdar)
+  (define-integrable section.lines cdr)
+
+  (define headline-pattern
+    (compile-regsexp '(seq (line-start)
+			   (group filename (+ (char-not-in #\,)))
+			   #\,
+			   (group bytecount (+ (char-in numeric)))
+			   (line-end))))
+
+  (define (write-section section out)
+    (write-string "\f\n" out)
+    (write-string (string (section.filename section)
+			  #\, (section.bytecount section)
+			  "\n")
+		  out)
+    (for-each (lambda (line) (write-string line out) (newline out))
+	      (section.lines section)))
+
+  (define (write-sections sections out)
+    (for-each (lambda (section) (write-section section out))
+	      (sort sections
+		    (lambda (a b)
+		      (string<? (section.filename a)
+				(section.filename b))))))
+
+  (define (read-section in)
+    (let loop ((lines '()))
+      (let ((line (read-line in)))
+	(if (or (eof-object? line)
+		(string=? line "\f"))
+	    (reverse! lines)
+	    (loop (cons line lines))))))
+
+  (define (rewriter in out)
+    (let ((line (read-line in)))
+      (cond ((eof-object? line)
+	     (error "TAGS file is empty"))
+	    ((not (string=? line "\f"))
+	     (error "TAGS file does not start with a formfeed:" line))))
+    (let loop ((scms '()) (chs '()) (cdecls '()) (rest '()))
+      (let ((line (read-line in)))
+	(if (eof-object? line)
+	    (begin
+	      (write-sections scms out)
+	      (write-sections chs out)
+	      (write-sections rest out)
+	      (write-sections cdecls out))
+	    (let ((match (regsexp-match-string headline-pattern line)))
+	      (if (not match)
+		  (error "TAGS file contains a bogus headline:" line))
+	      (let ((filename (cdr (assq 'filename (cddr match))))
+		    (section (make-section (cdr (assq 'filename (cddr match)))
+					   (cdr (assq 'bytecount (cddr match)))
+					   (read-section in))))
+		(cond ((or (string-suffix? "-shim.c" filename)
+			   (string-suffix? "-const.c" filename))
+		       (loop scms chs cdecls rest))
+		      ((string-suffix? ".scm" filename)
+		       (loop (cons section scms) chs cdecls rest))
+		      ((or (string-suffix? ".c" filename)
+			   (string-suffix? ".h" filename))
+		       (loop scms (cons section chs) cdecls rest))
+		      ((string-suffix? ".cdecl" filename)
+		       (loop scms chs (cons section cdecls) rest))
+		      (else
+		       (loop scms chs cdecls (cons section rest))))))))))
+
+  (parameterize ((param:suppress-loading-message? #t))
+    (load-option 'ffi))
+  ((access rewrite-file (->environment '(ffi build)))
+   (merge-pathnames "TAGS")
+   rewriter))
 EOF
diff --git a/src/mcrypt/Makefile.am b/src/mcrypt/Makefile.am
index 5e097d0ea..7f5419721 100644
--- a/src/mcrypt/Makefile.am
+++ b/src/mcrypt/Makefile.am
@@ -88,10 +88,9 @@ CLEANFILES += @MIT_SCHEME_CLEAN@
 TESTS = mcrypt-check.sh
 CLEANFILES += encrypted decrypted
 
-tags: tags-am
-	./tags-fix.sh mcrypt
-
-TAGS_FILES = $(sources) mcrypt-adapter.c $(cdecls)
+tags: tags-am $(sources) $(cdecls)
+	$(ETAGS) -a $(sources) -r '/^([^iI].*/' $(cdecls)
+	./tags-fix.sh
 
 EXTRA_DIST += $(sources) $(cdecls)
 EXTRA_DIST += compile.sh compile.scm mcrypt.pkg
diff --git a/src/mcrypt/tags-fix.sh b/src/mcrypt/tags-fix.sh
index a22e6bab5..6fda030bf 100755
--- a/src/mcrypt/tags-fix.sh
+++ b/src/mcrypt/tags-fix.sh
@@ -1,42 +1,89 @@
 #!/bin/sh
 # -*-Scheme-*-
 #
-# Chop the generated $1-shim.c and $1-const.c files out of TAGS.
+# Changes to TAGS:
+#   + Punt any generated *-shim.c and *-const.c files.
+#   + Re-order the files: .scm first, .[hc] next, whatnot, and .cdecls last.
 
 set -e
 : ${MIT_SCHEME_EXE=mit-scheme}
 ${MIT_SCHEME_EXE} --batch-mode -- ${1+"$@"} <<\EOF
-(let ((name (car (command-line-arguments))))
-  (let ((shim.c-prefix (string-append name "-shim.c,"))
-	(const.c-prefix (string-append name "-const.c,")))
-
-    (define (rewriter in out)
-      (let loop ((skipping? #f))
-	(let ((line (read-line in)))
-	  (cond ((eof-object? line)
-		 unspecific)
-		((string=? line "\f")
-		 (let ((next (read-line in)))
-		   (cond ((eof-object? next) (error "Bogus TAGS format:" next))
-			 ((or (string-prefix? shim.c-prefix next)
-			      (string-prefix? const.c-prefix next))
-			  (loop #t))
-			 (else
-			  (write-string line out)
-			  (newline out)
-			  (write-string next out)
-			  (newline out)
-			  (loop #f)))))
-		(skipping?
-		 (loop skipping?))
-		(else
-		 (write-string line out)
-		 (newline out)
-		 (loop skipping?))))))
-
-    (parameterize ((param:suppress-loading-message? #t))
-      (load-option 'FFI))
-    ((access rewrite-file (->environment '(ffi build)))
-     (merge-pathnames "TAGS")
-     rewriter)))
+(let ()
+
+  (define-integrable (make-section filename bytecount lines)
+    (cons (cons filename bytecount) lines))
+  (define-integrable section.filename caar)
+  (define-integrable section.bytecount cdar)
+  (define-integrable section.lines cdr)
+
+  (define headline-pattern
+    (compile-regsexp '(seq (line-start)
+			   (group filename (+ (char-not-in #\,)))
+			   #\,
+			   (group bytecount (+ (char-in numeric)))
+			   (line-end))))
+
+  (define (write-section section out)
+    (write-string "\f\n" out)
+    (write-string (string (section.filename section)
+			  #\, (section.bytecount section)
+			  "\n")
+		  out)
+    (for-each (lambda (line) (write-string line out) (newline out))
+	      (section.lines section)))
+
+  (define (write-sections sections out)
+    (for-each (lambda (section) (write-section section out))
+	      (sort sections
+		    (lambda (a b)
+		      (string<? (section.filename a)
+				(section.filename b))))))
+
+  (define (read-section in)
+    (let loop ((lines '()))
+      (let ((line (read-line in)))
+	(if (or (eof-object? line)
+		(string=? line "\f"))
+	    (reverse! lines)
+	    (loop (cons line lines))))))
+
+  (define (rewriter in out)
+    (let ((line (read-line in)))
+      (cond ((eof-object? line)
+	     (error "TAGS file is empty"))
+	    ((not (string=? line "\f"))
+	     (error "TAGS file does not start with a formfeed:" line))))
+    (let loop ((scms '()) (chs '()) (cdecls '()) (rest '()))
+      (let ((line (read-line in)))
+	(if (eof-object? line)
+	    (begin
+	      (write-sections scms out)
+	      (write-sections chs out)
+	      (write-sections rest out)
+	      (write-sections cdecls out))
+	    (let ((match (regsexp-match-string headline-pattern line)))
+	      (if (not match)
+		  (error "TAGS file contains a bogus headline:" line))
+	      (let ((filename (cdr (assq 'filename (cddr match))))
+		    (section (make-section (cdr (assq 'filename (cddr match)))
+					   (cdr (assq 'bytecount (cddr match)))
+					   (read-section in))))
+		(cond ((or (string-suffix? "-shim.c" filename)
+			   (string-suffix? "-const.c" filename))
+		       (loop scms chs cdecls rest))
+		      ((string-suffix? ".scm" filename)
+		       (loop (cons section scms) chs cdecls rest))
+		      ((or (string-suffix? ".c" filename)
+			   (string-suffix? ".h" filename))
+		       (loop scms (cons section chs) cdecls rest))
+		      ((string-suffix? ".cdecl" filename)
+		       (loop scms chs (cons section cdecls) rest))
+		      (else
+		       (loop scms chs cdecls (cons section rest))))))))))
+
+  (parameterize ((param:suppress-loading-message? #t))
+    (load-option 'ffi))
+  ((access rewrite-file (->environment '(ffi build)))
+   (merge-pathnames "TAGS")
+   rewriter))
 EOF
diff --git a/src/pgsql/Makefile.am b/src/pgsql/Makefile.am
index 87eb85c85..9f0bfb7e2 100644
--- a/src/pgsql/Makefile.am
+++ b/src/pgsql/Makefile.am
@@ -87,10 +87,9 @@ CLEANFILES += @MIT_SCHEME_CLEAN@
 TESTS = pgsql-check.sh
 CLEANFILES += pgsql-check.db
 
-tags: tags-am
-	./tags-fix.sh pgsql
-
-TAGS_FILES = $(sources) $(cdecls)
+tags: tags-am $(sources) $(cdecls)
+	$(ETAGS) -a $(sources) -r '/^([^iI].*/' $(cdecls)
+	./tags-fix.sh
 
 EXTRA_DIST += $(sources) $(cdecls)
 EXTRA_DIST += compile.sh compile.scm pgsql.pkg
diff --git a/src/pgsql/tags-fix.sh b/src/pgsql/tags-fix.sh
index a22e6bab5..6fda030bf 100755
--- a/src/pgsql/tags-fix.sh
+++ b/src/pgsql/tags-fix.sh
@@ -1,42 +1,89 @@
 #!/bin/sh
 # -*-Scheme-*-
 #
-# Chop the generated $1-shim.c and $1-const.c files out of TAGS.
+# Changes to TAGS:
+#   + Punt any generated *-shim.c and *-const.c files.
+#   + Re-order the files: .scm first, .[hc] next, whatnot, and .cdecls last.
 
 set -e
 : ${MIT_SCHEME_EXE=mit-scheme}
 ${MIT_SCHEME_EXE} --batch-mode -- ${1+"$@"} <<\EOF
-(let ((name (car (command-line-arguments))))
-  (let ((shim.c-prefix (string-append name "-shim.c,"))
-	(const.c-prefix (string-append name "-const.c,")))
-
-    (define (rewriter in out)
-      (let loop ((skipping? #f))
-	(let ((line (read-line in)))
-	  (cond ((eof-object? line)
-		 unspecific)
-		((string=? line "\f")
-		 (let ((next (read-line in)))
-		   (cond ((eof-object? next) (error "Bogus TAGS format:" next))
-			 ((or (string-prefix? shim.c-prefix next)
-			      (string-prefix? const.c-prefix next))
-			  (loop #t))
-			 (else
-			  (write-string line out)
-			  (newline out)
-			  (write-string next out)
-			  (newline out)
-			  (loop #f)))))
-		(skipping?
-		 (loop skipping?))
-		(else
-		 (write-string line out)
-		 (newline out)
-		 (loop skipping?))))))
-
-    (parameterize ((param:suppress-loading-message? #t))
-      (load-option 'FFI))
-    ((access rewrite-file (->environment '(ffi build)))
-     (merge-pathnames "TAGS")
-     rewriter)))
+(let ()
+
+  (define-integrable (make-section filename bytecount lines)
+    (cons (cons filename bytecount) lines))
+  (define-integrable section.filename caar)
+  (define-integrable section.bytecount cdar)
+  (define-integrable section.lines cdr)
+
+  (define headline-pattern
+    (compile-regsexp '(seq (line-start)
+			   (group filename (+ (char-not-in #\,)))
+			   #\,
+			   (group bytecount (+ (char-in numeric)))
+			   (line-end))))
+
+  (define (write-section section out)
+    (write-string "\f\n" out)
+    (write-string (string (section.filename section)
+			  #\, (section.bytecount section)
+			  "\n")
+		  out)
+    (for-each (lambda (line) (write-string line out) (newline out))
+	      (section.lines section)))
+
+  (define (write-sections sections out)
+    (for-each (lambda (section) (write-section section out))
+	      (sort sections
+		    (lambda (a b)
+		      (string<? (section.filename a)
+				(section.filename b))))))
+
+  (define (read-section in)
+    (let loop ((lines '()))
+      (let ((line (read-line in)))
+	(if (or (eof-object? line)
+		(string=? line "\f"))
+	    (reverse! lines)
+	    (loop (cons line lines))))))
+
+  (define (rewriter in out)
+    (let ((line (read-line in)))
+      (cond ((eof-object? line)
+	     (error "TAGS file is empty"))
+	    ((not (string=? line "\f"))
+	     (error "TAGS file does not start with a formfeed:" line))))
+    (let loop ((scms '()) (chs '()) (cdecls '()) (rest '()))
+      (let ((line (read-line in)))
+	(if (eof-object? line)
+	    (begin
+	      (write-sections scms out)
+	      (write-sections chs out)
+	      (write-sections rest out)
+	      (write-sections cdecls out))
+	    (let ((match (regsexp-match-string headline-pattern line)))
+	      (if (not match)
+		  (error "TAGS file contains a bogus headline:" line))
+	      (let ((filename (cdr (assq 'filename (cddr match))))
+		    (section (make-section (cdr (assq 'filename (cddr match)))
+					   (cdr (assq 'bytecount (cddr match)))
+					   (read-section in))))
+		(cond ((or (string-suffix? "-shim.c" filename)
+			   (string-suffix? "-const.c" filename))
+		       (loop scms chs cdecls rest))
+		      ((string-suffix? ".scm" filename)
+		       (loop (cons section scms) chs cdecls rest))
+		      ((or (string-suffix? ".c" filename)
+			   (string-suffix? ".h" filename))
+		       (loop scms (cons section chs) cdecls rest))
+		      ((string-suffix? ".cdecl" filename)
+		       (loop scms chs (cons section cdecls) rest))
+		      (else
+		       (loop scms chs cdecls (cons section rest))))))))))
+
+  (parameterize ((param:suppress-loading-message? #t))
+    (load-option 'ffi))
+  ((access rewrite-file (->environment '(ffi build)))
+   (merge-pathnames "TAGS")
+   rewriter))
 EOF
diff --git a/src/x11/Makefile.am b/src/x11/Makefile.am
index b1019cf24..aabd510d8 100644
--- a/src/x11/Makefile.am
+++ b/src/x11/Makefile.am
@@ -88,10 +88,9 @@ CLEANFILES += @MIT_SCHEME_CLEAN@
 
 TESTS = x11-check.sh
 
-tags: tags-am
-	./tags-fix.sh x11
-
-TAGS_FILES = $(sources) $(cdecls)
+tags: tags-am $(sources) $(cdecls)
+	$(ETAGS) -a $(sources) -r '/^([^iI].*/' $(cdecls)
+	./tags-fix.sh
 
 EXTRA_DIST += $(sources) $(cdecls)
 EXTRA_DIST += compile.sh compile.scm x11.pkg
diff --git a/src/x11/tags-fix.sh b/src/x11/tags-fix.sh
index a22e6bab5..6fda030bf 100755
--- a/src/x11/tags-fix.sh
+++ b/src/x11/tags-fix.sh
@@ -1,42 +1,89 @@
 #!/bin/sh
 # -*-Scheme-*-
 #
-# Chop the generated $1-shim.c and $1-const.c files out of TAGS.
+# Changes to TAGS:
+#   + Punt any generated *-shim.c and *-const.c files.
+#   + Re-order the files: .scm first, .[hc] next, whatnot, and .cdecls last.
 
 set -e
 : ${MIT_SCHEME_EXE=mit-scheme}
 ${MIT_SCHEME_EXE} --batch-mode -- ${1+"$@"} <<\EOF
-(let ((name (car (command-line-arguments))))
-  (let ((shim.c-prefix (string-append name "-shim.c,"))
-	(const.c-prefix (string-append name "-const.c,")))
-
-    (define (rewriter in out)
-      (let loop ((skipping? #f))
-	(let ((line (read-line in)))
-	  (cond ((eof-object? line)
-		 unspecific)
-		((string=? line "\f")
-		 (let ((next (read-line in)))
-		   (cond ((eof-object? next) (error "Bogus TAGS format:" next))
-			 ((or (string-prefix? shim.c-prefix next)
-			      (string-prefix? const.c-prefix next))
-			  (loop #t))
-			 (else
-			  (write-string line out)
-			  (newline out)
-			  (write-string next out)
-			  (newline out)
-			  (loop #f)))))
-		(skipping?
-		 (loop skipping?))
-		(else
-		 (write-string line out)
-		 (newline out)
-		 (loop skipping?))))))
-
-    (parameterize ((param:suppress-loading-message? #t))
-      (load-option 'FFI))
-    ((access rewrite-file (->environment '(ffi build)))
-     (merge-pathnames "TAGS")
-     rewriter)))
+(let ()
+
+  (define-integrable (make-section filename bytecount lines)
+    (cons (cons filename bytecount) lines))
+  (define-integrable section.filename caar)
+  (define-integrable section.bytecount cdar)
+  (define-integrable section.lines cdr)
+
+  (define headline-pattern
+    (compile-regsexp '(seq (line-start)
+			   (group filename (+ (char-not-in #\,)))
+			   #\,
+			   (group bytecount (+ (char-in numeric)))
+			   (line-end))))
+
+  (define (write-section section out)
+    (write-string "\f\n" out)
+    (write-string (string (section.filename section)
+			  #\, (section.bytecount section)
+			  "\n")
+		  out)
+    (for-each (lambda (line) (write-string line out) (newline out))
+	      (section.lines section)))
+
+  (define (write-sections sections out)
+    (for-each (lambda (section) (write-section section out))
+	      (sort sections
+		    (lambda (a b)
+		      (string<? (section.filename a)
+				(section.filename b))))))
+
+  (define (read-section in)
+    (let loop ((lines '()))
+      (let ((line (read-line in)))
+	(if (or (eof-object? line)
+		(string=? line "\f"))
+	    (reverse! lines)
+	    (loop (cons line lines))))))
+
+  (define (rewriter in out)
+    (let ((line (read-line in)))
+      (cond ((eof-object? line)
+	     (error "TAGS file is empty"))
+	    ((not (string=? line "\f"))
+	     (error "TAGS file does not start with a formfeed:" line))))
+    (let loop ((scms '()) (chs '()) (cdecls '()) (rest '()))
+      (let ((line (read-line in)))
+	(if (eof-object? line)
+	    (begin
+	      (write-sections scms out)
+	      (write-sections chs out)
+	      (write-sections rest out)
+	      (write-sections cdecls out))
+	    (let ((match (regsexp-match-string headline-pattern line)))
+	      (if (not match)
+		  (error "TAGS file contains a bogus headline:" line))
+	      (let ((filename (cdr (assq 'filename (cddr match))))
+		    (section (make-section (cdr (assq 'filename (cddr match)))
+					   (cdr (assq 'bytecount (cddr match)))
+					   (read-section in))))
+		(cond ((or (string-suffix? "-shim.c" filename)
+			   (string-suffix? "-const.c" filename))
+		       (loop scms chs cdecls rest))
+		      ((string-suffix? ".scm" filename)
+		       (loop (cons section scms) chs cdecls rest))
+		      ((or (string-suffix? ".c" filename)
+			   (string-suffix? ".h" filename))
+		       (loop scms (cons section chs) cdecls rest))
+		      ((string-suffix? ".cdecl" filename)
+		       (loop scms chs (cons section cdecls) rest))
+		      (else
+		       (loop scms chs cdecls (cons section rest))))))))))
+
+  (parameterize ((param:suppress-loading-message? #t))
+    (load-option 'ffi))
+  ((access rewrite-file (->environment '(ffi build)))
+   (merge-pathnames "TAGS")
+   rewriter))
 EOF