mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 11:40:18 +02:00
* snarf-check-and-output-texi: rewrite.
This commit is contained in:
Michael Livshin
parent
ac13d9d210
commit
58e17e276b
2 changed files with 198 additions and 71 deletions
|
|
@ -1,3 +1,7 @@
|
||||||
|
2001-06-25 Michael Livshin <mlivshin@bigfoot.com>
|
||||||
|
|
||||||
|
* snarf-check-and-output-texi: rewrite.
|
||||||
|
|
||||||
2001-05-31 Michael Livshin <mlivshin@bigfoot.com>
|
2001-05-31 Michael Livshin <mlivshin@bigfoot.com>
|
||||||
|
|
||||||
* snarf-check-and-output-texi: new file.
|
* snarf-check-and-output-texi: new file.
|
||||||
|
|
|
||||||
|
|
@ -27,8 +27,99 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@"
|
||||||
;;; Code:
|
;;; Code:
|
||||||
|
|
||||||
(define-module (scripts snarf-check-and-output-texi)
|
(define-module (scripts snarf-check-and-output-texi)
|
||||||
|
:use-module (ice-9 streams)
|
||||||
|
:use-module (ice-9 match)
|
||||||
:export (snarf-check-and-output-texi))
|
: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 (snarf-check-and-output-texi)
|
||||||
|
(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 *file* #f)
|
||||||
(define *line* #f)
|
(define *line* #f)
|
||||||
(define *function-name* #f)
|
(define *function-name* #f)
|
||||||
|
|
@ -37,62 +128,16 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@"
|
||||||
(define *sig* #f)
|
(define *sig* #f)
|
||||||
(define *docstring* #f)
|
(define *docstring* #f)
|
||||||
|
|
||||||
(define (doc-block args)
|
(define (begin-multiline)
|
||||||
(let loop ((args args))
|
(set! *file* #f)
|
||||||
(if (not (null? args))
|
(set! *line* #f)
|
||||||
(let ((arg (car args)))
|
(set! *function-name* #f)
|
||||||
(if (not (null? arg))
|
(set! *snarf-type* #f)
|
||||||
(begin
|
(set! *args* #f)
|
||||||
|
(set! *sig* #f)
|
||||||
(case (car arg)
|
(set! *docstring* #f))
|
||||||
|
|
||||||
((fname)
|
|
||||||
(set! *function-name* (cdr arg)))
|
|
||||||
|
|
||||||
((type)
|
|
||||||
(set! *snarf-type* (cdr arg)))
|
|
||||||
|
|
||||||
((location)
|
|
||||||
(set! *file* (cadr arg))
|
|
||||||
(set! *line* (cddr arg)))
|
|
||||||
|
|
||||||
((arglist)
|
|
||||||
(set! *args* (cdr arg)))
|
|
||||||
|
|
||||||
((argsig)
|
|
||||||
(set! *sig* (cdr arg)))
|
|
||||||
|
|
||||||
((docstring)
|
|
||||||
(set! *docstring* (cdr arg)))
|
|
||||||
|
|
||||||
(else
|
|
||||||
(error (format #f "unknown doc attribute: ~A" (car arg)))))))
|
|
||||||
(loop (cdr args)))))
|
|
||||||
(output-doc-block))
|
|
||||||
|
|
||||||
(define (doc-check arg)
|
|
||||||
(if (not (null? arg))
|
|
||||||
|
|
||||||
(case (car arg)
|
(define (end-multiline)
|
||||||
|
|
||||||
((argpos)
|
|
||||||
(let* ((name (cadr arg))
|
|
||||||
(pos (caddr arg))
|
|
||||||
(line (cadddr arg))
|
|
||||||
(idx (list-index *args* name)))
|
|
||||||
(cond
|
|
||||||
((not idx))
|
|
||||||
((not (number? pos)))
|
|
||||||
((= 0 pos))
|
|
||||||
((not (= (+ 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))))))
|
|
||||||
|
|
||||||
(else
|
|
||||||
(error (format #f "unknown check: ~A" (car arg)))))))
|
|
||||||
|
|
||||||
(define (output-doc-block)
|
|
||||||
(let* ((req (car *sig*))
|
(let* ((req (car *sig*))
|
||||||
(opt (cadr *sig*))
|
(opt (cadr *sig*))
|
||||||
(var (caddr *sig*))
|
(var (caddr *sig*))
|
||||||
|
|
@ -137,21 +182,99 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@"
|
||||||
(loop (cdr strings)))))
|
(loop (cdr strings)))))
|
||||||
(display "\n@end deffn\n"))))
|
(display "\n@end deffn\n"))))
|
||||||
|
|
||||||
(define (snarf-check-and-output-texi)
|
(define (texi-quote s)
|
||||||
(let loop ((form (read)))
|
(let rec ((i 0))
|
||||||
(if (not (eof-object? form))
|
(if (= i (string-length s))
|
||||||
(begin
|
""
|
||||||
(if (not (null? form))
|
(string-append (let ((ss (substring s i (+ i 1))))
|
||||||
|
(if (string=? ss "@")
|
||||||
(case (car form)
|
"@@"
|
||||||
|
ss))
|
||||||
((doc-block)
|
(rec (+ i 1))))))
|
||||||
(doc-block (cdr form)))
|
|
||||||
|
(define (process-multiline-directive l)
|
||||||
((doc-check)
|
|
||||||
(doc-check (cdr form)))
|
(define do-args
|
||||||
|
(match-lambda
|
||||||
(else (error (format #f "unknown doc command: ~A" (car form))))))
|
|
||||||
(loop (read))))))
|
(('(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
|
||||||
|
|
||||||
|
(('fname ('string . name))
|
||||||
|
(set! *function-name* (texi-quote 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))
|
||||||
|
|
||||||
|
(('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)))))))
|
||||||
|
(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)
|
(define main snarf-check-and-output-texi)
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue