tags: first cut at handling .txr files.

Handles only top-level define and bind.

* tags.tl (with-tag-shorthand-macro): New macro: a robot for
writing the the shorthand macrolet in collect-tags, so we can reuse it.
(process-form): New function, made from the bulk of
collect-tags.
(collect-tags): Renamed to collect-tags-tl. The macrolet is
replaced by invocation of with-tag-shorthand macro and the
form case processing logic by a call to process-form.
(process-clause, collect-tags-txr, collect-tags-guess): New
functions.
(toplevel): Help text updated. Process .txr files through
collect-tags-txr. Also process unsuffixed files, if they are
explicity mentioned on the command line, through
collect-tags-guess, which looks for hash-bang lines containing
the --lisp option.

1 files changed, 114 insertions, 65 deletions

diff --git a/tags.tl b/tags.tl
index 8580ca7a..66561d08 100755
--- a/tags.tl
+++ b/tags.tl
@@ -62,7 +62,84 @@
   (tree-case (source-loc form)
     ((line . file) (escape [lines line]))))
 
-(defun collect-tags (path)
+(defmacro with-tag-shorthand-macro ((name-sym path-var lines-var obj-var)
+                                    . body)
+  ^(macrolet ((,name-sym (type ident : parent pattern-obj)
+                ^(new ,type ident ,ident
+                            path ,',path-var
+                            pattern ,*(if pattern-obj
+                                        ^((get-pat ,',lines-var ,pattern-obj))
+                                        ^((get-pat ,',lines-var ,',obj-var)))
+                            ,*(if parent ^(parent ,parent))
+                            ,*(if pattern-obj ^(expattern t)))))
+    ,*body))
+
+(defun process-form (path lines obj)
+  (build
+    (with-tag-shorthand-macro (ntag path lines obj)
+      (when (consp obj)
+        (caseq (car obj)
+          ((progn eval-only compile-only with-dyn-lib)
+           [mapdo (op process-form path lines) (cdr obj)])
+          ((defun defmacro define-place-macro deffi deffi-cb)
+           (add (ntag fun-tag (cadr obj))))
+          ((defvar defvarl defparm defparml defsymacro)
+           (add (ntag var-tag (cadr obj))))
+          ((defmeth)
+           (add (ntag slot-tag (caddr obj) (cadr obj))))
+          ((defplace)
+           (tree-bind (op (name . args) . body) obj
+             (add (ntag fun-tag name))))
+          ((typedef)
+           (add (ntag type-tag (cadr obj))))
+          ((defpackage)
+           (add (ntag struct-tag (cadr obj))))
+          ((define-option-struct)
+           (let ((struct-name (cadr obj)))
+             (add (ntag struct-tag struct-name))
+             (each ((obj (cdddr obj)))
+               (tree-bind (short long . rest) obj
+                 (cond
+                   (long (add (ntag slot-tag long struct-name)))
+                   (short (add (ntag slot-tag short struct-name))))))))
+          ((defstruct)
+           (let ((struct-obj obj)
+                 (struct-name (tree-case (cadr obj)
+                                ((atom . rest) atom)
+                                (atom atom))))
+             (add (ntag struct-tag struct-name))
+             (each ((obj (cdddr obj)))
+               (tree-case obj
+                 ((word name . rest)
+                  (caseq word
+                    ((:method :function :static :instance)
+                     (add (ntag slot-tag name struct-name)))
+                    (t :)))
+                 ((word (arg) . body)
+                  (caseq word
+                    ((:init :postinit :fini))
+                    (t :)))
+                 ((name . rest)
+                  (add (ntag slot-tag name struct-name)))
+                 (name
+                   (add (ntag slot-tag name struct-name struct-obj))))))))))))
+
+(defun process-clause (path lines clause)
+  (when (consp clause)
+    (let ((elem (car clause)))
+      (build
+        (with-tag-shorthand-macro (ntag path lines elem)
+          (when (consp elem)
+            (caseq (car elem)
+              (define (let ((args (if (eq t (cadr elem))
+                                    (cadddr elem)
+                                    (cadr elem))))
+                        (add (ntag fun-tag (car args)))))
+              (bind (let ((syms (flatten (cadr elem))))
+                      (each ((sym syms))
+                        (add (ntag fun-tag sym))))))))))))
+
+(defun collect-tags-tl (path)
   (let* ((text (file-get-string path))
          (text (if (starts-with "#!" text) `;@text` text))
          (lines (cons "" (spl #\newline text)))
@@ -71,64 +148,32 @@
     (build
       (add (new file-tag
                 path path))
-      (macrolet ((ntag (type ident : parent pattern-obj)
-                   ^(new ,type ident ,ident
-                               path path
-                               pattern ,*(if pattern-obj
-                                           ^((get-pat lines ,pattern-obj))
-                                           ^((get-pat lines obj)))
-                               ,*(if parent ^(parent ,parent))
-                               ,*(if pattern-obj ^(expattern t)))))
-        (labels ((process-form (obj)
-                   (when (consp obj)
-                     (caseq (car obj)
-                       ((progn eval-only compile-only with-dyn-lib)
-                        [mapdo process-form (cdr obj)])
-                       ((defun defmacro define-place-macro deffi deffi-cb)
-                        (add (ntag fun-tag (cadr obj))))
-                       ((defvar defvarl defparm defparml defsymacro)
-                        (add (ntag var-tag (cadr obj))))
-                       ((defmeth)
-                        (add (ntag slot-tag (caddr obj) (cadr obj))))
-                       ((defplace)
-                        (tree-bind (op (name . args) . body) obj
-                          (add (ntag fun-tag name))))
-                       ((typedef)
-                        (add (ntag type-tag (cadr obj))))
-                       ((defpackage)
-                        (add (ntag struct-tag (cadr obj))))
-                       ((define-option-struct)
-                        (let ((struct-name (cadr obj)))
-                          (add (ntag struct-tag struct-name))
-                          (each ((obj (cdddr obj)))
-                            (tree-bind (short long . rest) obj
-                              (cond
-                                (long (add (ntag slot-tag long struct-name)))
-                                (short (add (ntag slot-tag short struct-name))))))))
-                       ((defstruct)
-                        (let ((struct-obj obj)
-                              (struct-name (tree-case (cadr obj)
-                                             ((atom . rest) atom)
-                                             (atom atom))))
-                          (add (ntag struct-tag struct-name))
-                          (each ((obj (cdddr obj)))
-                            (tree-case obj
-                              ((word name . rest)
-                               (caseq word
-                                 ((:method :function :static :instance)
-                                  (add (ntag slot-tag name struct-name)))
-                                 (t :)))
-                              ((word (arg) . body)
-                               (caseq word
-                                 ((:init :postinit :fini))
-                                 (t :)))
-                              ((name . rest)
-                               (add (ntag slot-tag name struct-name)))
-                              (name
-                               (add (ntag slot-tag name struct-name struct-obj)))))))))))
-          (whilet ((obj (read stream *stderr* err-ret path))
-                   ((neq obj err-ret)))
-            (process-form obj)))))))
+      (whilet ((obj (read stream *stderr* err-ret path))
+               ((neq obj err-ret)))
+        (pend (process-form path lines obj))))))
+
+(defun collect-tags-txr (path)
+  (let* ((text (file-get-string path))
+         (text (if (starts-with "#!" text) `\@;@text` text))
+         (lines (cons "" (spl #\newline text)))
+         (stream (make-string-byte-input-stream text))
+         (*rec-source-loc* t)
+         (syntax (txr-parse stream *stderr* nil path)))
+    (build
+      (each ((clause syntax))
+        (pend (process-clause path lines clause))))))
+
+(defun collect-tags-guess (path)
+  (with-stream (s (open-file path))
+    (iflet ((line (get-line s)))
+      (if (and (starts-with "#!" line)
+               (search-str line "txr"))
+        (if (search-str line "--lisp")
+          (collect-tags-tl path)
+          (collect-tags-txr path))
+        (progn
+          (put-line `@path: unable to determine file type` *stderr*)
+          nil)))))
 
 (defun write-tagfile (tags o)
   (when o.merge
@@ -156,7 +201,7 @@
     (when o.help
       (put-line "\nUsage:\n")
       (put-line `  @{*load-path*} [options] {file|dir}*\n`)
-      (put-line "Directory arguments are recursively searched for *.tl files.")
+      (put-line "Directory arguments are recursively searched for .tl and .txr files.")
       (put-line "If no arguments are given, the current directory is searched.")
       o.(opthelp)
       (exit t))
@@ -175,13 +220,17 @@
                    (ftw o.out-args
                         (lambda (path type stat . rest)
                           (caseql* type
-                            (ftw-f (when (and (or (member path o.out-args)
-                                                  (ends-with ".tl" path))
-                                              (not [excf path])
+                            (ftw-f (when (and (not [excf path])
                                               (not [excf (base-name path)])
                                               (not (some skips (op starts-with @1 path))))
-                                     (pend (ignerr (collect-tags path)))
-                                     ftw-continue))
+                                     (cond
+                                       ((ends-with ".tl" path)
+                                        (pend (ignerr (collect-tags-tl path))))
+                                       ((ends-with ".txr" path)
+                                        (pend (ignerr (collect-tags-txr path))))
+                                       ((member path o.out-args)
+                                        (pend (ignerr (collect-tags-guess path))))
+                                       (t ftw-continue))))
                             (ftw-d (while (and skips (starts-with path (car skips)))
                                      (pop skips))
                                    (cond