From 58e17e276b22a7a040e3b6f2b44009c85ebd2b5b Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Mon, 25 Jun 2001 03:30:32 +0000 Subject: [PATCH] * snarf-check-and-output-texi: rewrite. --- scripts/ChangeLog | 4 + scripts/snarf-check-and-output-texi | 265 ++++++++++++++++++++-------- 2 files changed, 198 insertions(+), 71 deletions(-) diff --git a/scripts/ChangeLog b/scripts/ChangeLog index d647d06f9..d7a8910d4 100644 --- a/scripts/ChangeLog +++ b/scripts/ChangeLog @@ -1,3 +1,7 @@ +2001-06-25 Michael Livshin + + * snarf-check-and-output-texi: rewrite. + 2001-05-31 Michael Livshin * snarf-check-and-output-texi: new file. diff --git a/scripts/snarf-check-and-output-texi b/scripts/snarf-check-and-output-texi index 4ba467272..7b4df63fd 100755 --- a/scripts/snarf-check-and-output-texi +++ b/scripts/snarf-check-and-output-texi @@ -27,8 +27,99 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;;; Code: (define-module (scripts snarf-check-and-output-texi) + :use-module (ice-9 streams) + :use-module (ice-9 match) :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 *line* #f) (define *function-name* #f) @@ -37,62 +128,16 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" (define *sig* #f) (define *docstring* #f) -(define (doc-block args) - (let loop ((args args)) - (if (not (null? args)) - (let ((arg (car args))) - (if (not (null? arg)) - (begin - - (case (car arg) - - ((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)) +(define (begin-multiline) + (set! *file* #f) + (set! *line* #f) + (set! *function-name* #f) + (set! *snarf-type* #f) + (set! *args* #f) + (set! *sig* #f) + (set! *docstring* #f)) - (case (car arg) - - ((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) +(define (end-multiline) (let* ((req (car *sig*)) (opt (cadr *sig*)) (var (caddr *sig*)) @@ -137,21 +182,99 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" (loop (cdr strings))))) (display "\n@end deffn\n")))) -(define (snarf-check-and-output-texi) - (let loop ((form (read))) - (if (not (eof-object? form)) - (begin - (if (not (null? form)) - - (case (car form) - - ((doc-block) - (doc-block (cdr form))) - - ((doc-check) - (doc-check (cdr form))) - - (else (error (format #f "unknown doc command: ~A" (car form)))))) - (loop (read)))))) +(define (texi-quote s) + (let rec ((i 0)) + (if (= i (string-length s)) + "" + (string-append (let ((ss (substring s i (+ i 1)))) + (if (string=? ss "@") + "@@" + ss)) + (rec (+ i 1)))))) + +(define (process-multiline-directive l) + + (define do-args + (match-lambda + + (('(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) -- 2.20.1