#!/usr/bin/env gsi ;;;; etags.scm - by Vincent St-Amour ;;;; generates an Emacs TAGS file from scheme files ;;;; recognizes internal defines (the main point of this) ;;;; mostly taken from etags.ss, by Guillaume Marceau (load "~~lib/pregexp.scm") (define (filter p l) (cond ((null? l) '()) ((p (car l)) (cons (car l) (filter p (cdr l)))) (else (filter p (cdr l))))) (define (find-first p l) (cond ((null? l) #f) ((p (car l)) (car l)) (else (find-first p (cdr l))))) (define (remove-first p l) (cond ((null? l) '()) ((p (car l)) (cdr l)) (else (cons (car l) (remove-first p (cdr l)))))) (define (process-file file) ;; definitions is a list of defined symbols ;; definition-lines is a list of lists (line-contents line-nb chars-so-far) (let ((definitions '()) (macro-definitions '())) ;; TODO add support for define-type, recognize extensors so we can go to the parent type, also add tg for each accessor, setter, extensor, etc (define (descend sexpr defs macro-defs) (if (pair? sexpr) (case (car sexpr) ((define) (if (>= (length sexpr) 3) ; define keyword, definee, body (descend (cddr sexpr) ; explore the body (cons (if (pair? (cadr sexpr)) ; function definition (caadr sexpr) (cadr sexpr)) defs) macro-defs) ;; ill-formed define, just like the above case pattern, stop (cons defs macro-defs))) ((define-macro) (if (>= (length sexpr) 3) (descend (cddr sexpr) defs (cons (caadr sexpr) defs)) (cons defs macro-defs))) ; same ((quote quasiquote) ; we don't descend into quotations (cons defs macro-defs)) (else (let* ((left (descend (car sexpr) defs macro-defs)) (right (descend (cdr sexpr) (car left) (cdr left)))) right))) (cons defs macro-defs))) ;; read-all throws an exception with files containing #! headers ;; this avoids the problem, but is a rather ugly solution (define (read-everything) (with-input-from-file file (lambda () (let loop ((sexpr #f) (sexprs '())) (if (eq? sexpr #!eof) (reverse sexprs) (with-exception-catcher (lambda (e) (loop (read) sexprs)) (lambda () (loop (read) (if sexpr (cons sexpr sexprs) sexprs))))))))) ;; search for definitions (let loop ((sexprs (read-everything)) (defs '()) (macro-defs '())) (if (null? sexprs) (begin (set! definitions (reverse defs)) (set! macro-definitions (reverse macro-defs))) (let ((res (descend (car sexprs) defs macro-defs))) (loop (cdr sexprs) (car res) (cdr res))))) ;; search for line numbers, we assume that the definition keyword and the ;; defined term are on the same line, and that there's only one definition ;; on each line (let* ((lines (with-input-from-file file (lambda () (let loop ((line (read-line)) (i 0) (pos 0) (lines '())) (if (eq? line #!eof) (reverse lines) (loop (read-line) (+ i 1) (+ pos (string-length line)) (cons (list line i pos) lines))))))) (def-lines (filter (lambda (x) (pregexp-match "define[ \t\n]" (car x))) lines)) (macro-def-lines (filter (lambda (x) (pregexp-match "define-macro" (car x))) lines))) (define (pair-up macros?) (let loop ((defs (if macros? macro-definitions definitions)) (lines (if macros? macro-def-lines def-lines)) (section "")) (if (null? defs) section (let* ((target (symbol->string (car defs))) (line (find-first (lambda (x) (pregexp-match (string-append (if macros? "define-macro" "define") "[ \t\n(]+" (pregexp-quote target)) (car x))) lines))) (define (remove-leading-whitespace s) (let loop ((i 0)) (if (memq (string-ref s i) '(#\space #\newline #\tab)) (loop (+ i 1)) (substring s i (string-length s))))) (loop (cdr defs) (remove-first (lambda (x) (equal? x line)) lines) (string-append section (car line) "" target "" (number->string (cadr line)) ; line number "," (number->string (caddr line)) ; char # in the file "\n")))))) (let ((section (string-append (pair-up #f) (pair-up #t)))) (display (string-append " \n" file "," (number->string (string-length section)) "\n" section)))))) (define (process-stdin) (let loop ((line (read-line))) (if (not (eq? line #!eof)) (process-file line) (loop (read-line))))) (define (main . args) (with-output-to-file "TAGS" (lambda () (let ((done-stdin #f)) (for-each (lambda (f) (if (and (equal? f "-") (not done-stdin)) (begin (process-stdin) (set! done-stdin #t)) (process-file f))) args)))))