diff options
| -rwxr-xr-x | tags.tl | 132 |
1 files changed, 65 insertions, 67 deletions
@@ -63,74 +63,72 @@ ((line . file) (escape [lines line])))) (defun collect-tags (path) - (let* ((lines (vec-list (cons "" (file-get-lines path)))) - (stream (make-strlist-input-stream lines)) + (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)) - (with-stream (stream (open-file path)) - (if (starts-with "#!" (get-line stream)) - (pop lines) - (seek-stream stream 0 :from-start)) - (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)) - ((neq obj err-ret))) - (process-form obj)))))))) + (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))))))) (defun write-tagfile (tags o) (when o.merge |