diff options
Diffstat (limited to 'schmooz.scm')
| -rw-r--r-- | schmooz.scm | 403 |
1 files changed, 213 insertions, 190 deletions
diff --git a/schmooz.scm b/schmooz.scm index e9950d2..f50a397 100644 --- a/schmooz.scm +++ b/schmooz.scm @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -17,6 +17,14 @@ ;promotional, or sales literature without prior written consent in ;each case. +(require 'common-list-functions) ;some +(require 'string-search) +(require 'fluid-let) +(require 'line-i/o) ;read-line +(require 'filename) + +;;(require 'debug) (set! *qp-width* 100) (define qreport qpn) + ;;; REPORT an error or warning (define report (lambda args @@ -37,14 +45,6 @@ (for-each (lambda (x) (write x) (display #\ )) args) (newline))) -(require 'common-list-functions) ;some -(require 'string-search) -(require 'fluid-let) -(require 'line-i/o) ;read-line -(require 'filename) -(require 'scanf) -;;(require 'debug) (set! *qp-width* 100) (define qreport qpn) - ;;; This allows us to test without generating files (define *scheme-source* (current-input-port)) (define *scheme-source-name* "stdin") @@ -225,7 +225,11 @@ ((DEFINE) (if (pair? name) name (form (caddr sexp)))) - ((DEFINE-SYNTAX) '()) + ((DEFINE-SYNTAX) + (case (caaddr sexp) + ((SYNTAX-RULES) + (caaddr (caddr sexp))) + (else '()))) ((DEFMACRO) (cons (cadr sexp) (caddr sexp))) ((DEFVAR DEFCONST) #f) (else (slib:error 'schmooz "doesn't look like definition" sexp)))) @@ -291,13 +295,21 @@ (else (slib:error 'schmooz-fun args)))))) (let* ((mac-list (scheme-args->macros args)) (ops (case defop - ((DEFINE-SYNTAX) '("defspec" . "defspecx")) - ((DEFMACRO) '("defmac" . "defmacx")) - (else '("defun" . "defunx"))))) + ((DEFINE-SYNTAX) '("defspec" "defspecx" "defspec")) + ((DEFMACRO) '("defmac" "defmacx" "defmac")) + (else + (if (and (symbol? (car args)) + (char=? (string-ref + (symbol->string (car args)) + (+ -1 (string-length (symbol->string + (car args))))) + #\!)) + '("deffn {Procedure}" "deffnx {Procedure}" "deffn") + '("defun" "defunx" "defun")))))) (out-header args (car ops)) (let loop ((xdefs xdefs)) (cond ((pair? xdefs) - (out-header (car xdefs) (cdr ops)) + (out-header (car xdefs) (cadr ops)) (loop (cdr xdefs))))) (for-each (lambda (subl) (out 0 (car subl)) @@ -308,12 +320,12 @@ ((@args) (out-header (cons (car args) (cdr l)) - (cdr ops))))) + (cadr ops))))) (cdr subl))) (map (lambda (bl) (substitute-macs bl mac-list)) body)) - (out 0 "@end " (car ops)) + (out 0 "@end " (caddr ops)) (out 0))) (define (schmooz-var defop name body xdefs) @@ -337,7 +349,16 @@ (out 0 "@end defvar") (out 0))) -;;; SCHMOOZ files. +(define (schmooz:read-word port) + (do ((chr (peek-char port) (peek-char port))) + ((not (and (char? chr) (char-whitespace? chr)))) + (read-char port)) + (do ((chr (peek-char port) (peek-char port)) + (str "" (string-append str (string chr)))) + ((not (and (char? chr) (not (char-whitespace? chr)))) str) + (read-char port))) + +;;;@ SCHMOOZ files. (define schmooz (let* ((scheme-file? (filename:match-ci?? "*??scm")) (txi-file? (filename:match-ci?? "*??txi")) @@ -354,8 +375,8 @@ (do ((pos (find-string-from-port? "@include" port) (find-string-from-port? "@include" port))) ((not pos)) - (let ((fname #f)) - (cond ((not (eqv? 1 (fscanf port " %s" fname)))) + (let ((fname (schmooz:read-word port))) + (cond ((equal? "" fname)) ((not (txi-file? fname))) ((not (file-exists? (txi->scm fname)))) (else (schmooz (txi->scm fname))))))))) @@ -384,176 +405,178 @@ files)))) ;;; SCHMOOZ-TOPS - schmooz top level forms. -(define (schmooz-tops schmooz-top) - (let ((doc-lines '()) - (doc-args #f)) - (define (skip-ws line istrt) - (do ((i istrt (+ i 1))) - ((or (>= i (string-length line)) - (not (memv (string-ref line i) - '(#\space #\tab #\;)))) - (substring line i (string-length line))))) - - (define (tok1 line) - (let loop ((i 0)) - (cond ((>= i (string-length line)) line) - ((or (char-whitespace? (string-ref line i)) - (memv (string-ref line i) '(#\; #\( #\{))) - (substring line 0 i)) - (else (loop (+ i 1)))))) - - (define (read-cmt-line) - (cond ((eqv? #\; (peek-char *scheme-source*)) - (read-char *scheme-source*) - (read-cmt-line)) - (else (read-line *scheme-source*)))) - - (define (read-meta-cmt) - (let skip ((metarg? #f)) - (let ((c (read-char *scheme-source*))) - (case c - ((#\newline) (if metarg? (skip #t))) - ((#\\) (skip #t)) - ((#\!) (cond ((eqv? #\# (peek-char *scheme-source*)) - (read-char *scheme-source*) - (if #f #f)) +(define schmooz-tops + (let ((semispaces (cons slib:tab '(#\space #\;)))) + (lambda (schmooz-top) + (let ((doc-lines '()) + (doc-args #f)) + (define (skip-ws line istrt) + (do ((i istrt (+ i 1))) + ((or (>= i (string-length line)) + (not (memv (string-ref line i) semispaces))) + (substring line i (string-length line))))) + + (define (tok1 line) + (let loop ((i 0)) + (cond ((>= i (string-length line)) line) + ((or (char-whitespace? (string-ref line i)) + (memv (string-ref line i) '(#\; #\( #\{))) + (substring line 0 i)) + (else (loop (+ i 1)))))) + + (define (read-cmt-line) + (cond ((eqv? #\; (peek-char *scheme-source*)) + (read-char *scheme-source*) + (read-cmt-line)) + (else (read-line *scheme-source*)))) + + (define (read-meta-cmt) + (let skip ((metarg? #f)) + (let ((c (read-char *scheme-source*))) + (case c + ((#\newline) (if metarg? (skip #t))) + ((#\\) (skip #t)) + ((#\!) (cond ((eqv? #\# (peek-char *scheme-source*)) + (read-char *scheme-source*) + (if #f #f)) + (else + (skip metarg?)))) + (else + (if (char? c) (skip metarg?) c)))))) + + (define (lp c) + (cond ((eof-object? c) + (cond ((pair? doc-lines) + (report "No definition found for @body doc lines" + (reverse doc-lines))))) + ((eqv? c #\newline) + (read-char *scheme-source*) + (set! *output-line* (+ 1 *output-line*)) + ;;(newline *derived-txi*) + (lp (peek-char *scheme-source*))) + ((char-whitespace? c) + (write-char (read-char *scheme-source*) *derived-txi*) + (lp (peek-char *scheme-source*))) + ((char=? c #\;) + (c-cmt c)) + ((char=? c #\#) + (read-char *scheme-source*) + (if (eqv? #\! (peek-char *scheme-source*)) + (read-meta-cmt) + (report "misread sharp object" (peek-char *scheme-source*))) + (lp (peek-char *scheme-source*))) + (else + (sx)))) + + (define (sx) + (let* ((s1 (read *scheme-source*)) + ;;Read all forms separated only by single newlines + ;;and trailing whitespace. + (ss (let recur () + (let ((c (peek-char *scheme-source*))) + (cond ((eof-object? c) '()) + ((eqv? c #\newline) + (read-char *scheme-source*) + (if (eqv? #\( (peek-char *scheme-source*)) + (let ((s (read *scheme-source*))) + (cons s (recur))) + '())) + ((char-whitespace? c) + (read-char *scheme-source*) + (recur)) + (else '())))))) + (cond ((eof-object? s1)) + (else + (schmooz-top s1 ss (reverse doc-lines) doc-args) + (set! doc-lines '()) + (set! doc-args #f) + (lp (peek-char *scheme-source*)))))) + + (define (out-cmt line) + (let ((subl (substitute-macs line '()))) + (display (car subl) *derived-txi*) + (for-each + (lambda (l) + (case (car l) + ((@dfn) + (out-cindex (cadr l))) + (else + (report "bad macro" line)))) + (cdr subl)) + (newline *derived-txi*))) + + ;;Comments not transcribed to generated Texinfo files. + (define (c-cmt c) + (cond ((eof-object? c) (lp c)) + ((eqv? #\; c) + (read-char *scheme-source*) + (c-cmt (peek-char *scheme-source*))) + ;; Escape to start Texinfo comments + ((eqv? #\@ c) + (let* ((line (read-line *scheme-source*)) + (tok (tok1 line))) + (cond ((or (string=? tok "@body") + (string=? tok "@text")) + (set! doc-lines + (cons (skip-ws line (string-length tok)) + doc-lines)) + (body-cmt (peek-char *scheme-source*))) + ((string=? tok "@args") + (let ((args + (parse-args line (string-length tok)))) + (set! doc-args (cdr args)) + (set! doc-lines + (cons (skip-ws line (car args)) + doc-lines))) + (body-cmt (peek-char *scheme-source*))) (else - (skip metarg?)))) - (else - (if (char? c) (skip metarg?) c)))))) - - (define (lp c) - (cond ((eof-object? c) - (cond ((pair? doc-lines) - (report "No definition found for @body doc lines" - (reverse doc-lines))))) - ((eqv? c #\newline) - (read-char *scheme-source*) - (set! *output-line* (+ 1 *output-line*)) - ;;(newline *derived-txi*) - (lp (peek-char *scheme-source*))) - ((char-whitespace? c) - (write-char (read-char *scheme-source*) *derived-txi*) - (lp (peek-char *scheme-source*))) - ((char=? c #\;) - (c-cmt c)) - ((char=? c #\#) - (read-char *scheme-source*) - (if (eqv? #\! (peek-char *scheme-source*)) - (read-meta-cmt) - (report "misread sharp object" (peek-char *scheme-source*))) - (lp (peek-char *scheme-source*))) - (else - (sx)))) - - (define (sx) - (let* ((s1 (read *scheme-source*)) - ;;Read all forms separated only by single newlines - ;;and trailing whitespace. - (ss (let recur () - (let ((c (peek-char *scheme-source*))) - (cond ((eqv? c #\newline) - (read-char *scheme-source*) - (if (eqv? #\( (peek-char *scheme-source*)) - (let ((s (read *scheme-source*))) - (cons s (recur))) - '())) - ((char-whitespace? c) - (read-char *scheme-source*) - (recur)) - (else '())))))) - (cond ((eof-object? s1)) - (else - (schmooz-top s1 ss (reverse doc-lines) doc-args) - (set! doc-lines '()) - (set! doc-args #f) - (lp (peek-char *scheme-source*)))))) - - (define (out-cmt line) - (let ((subl (substitute-macs line '()))) - (display (car subl) *derived-txi*) - (for-each - (lambda (l) - (case (car l) - ((@dfn) - (out-cindex (cadr l))) - (else - (report "bad macro" line)))) - (cdr subl)) - (newline *derived-txi*))) - - ;;Comments not transcribed to generated Texinfo files. - (define (c-cmt c) - (cond ((eof-object? c) (lp c)) - ((eqv? #\; c) - (read-char *scheme-source*) - (c-cmt (peek-char *scheme-source*))) - ;; Escape to start Texinfo comments - ((eqv? #\@ c) - (let* ((line (read-line *scheme-source*)) - (tok (tok1 line))) - (cond ((or (string=? tok "@body") - (string=? tok "@text")) - (set! doc-lines - (cons (skip-ws line (string-length tok)) - doc-lines)) - (body-cmt (peek-char *scheme-source*))) - ((string=? tok "@args") - (let ((args - (parse-args line (string-length tok)))) - (set! doc-args (cdr args)) - (set! doc-lines - (cons (skip-ws line (car args)) - doc-lines))) - (body-cmt (peek-char *scheme-source*))) - (else - (out-cmt (if (string=? tok "@") - (skip-ws line 1) - line)) - (doc-cmt (peek-char *scheme-source*)))))) - ;; Transcribe the comment line to C source file. - (else - (read-line *scheme-source*) - (lp (peek-char *scheme-source*))))) - - ;;Comments incorporated in generated Texinfo files. - ;;Continue adding lines to DOC-LINES until a non-comment - ;;line is reached (may be a blank line). - (define (body-cmt c) - (cond ((eof-object? c) (lp c)) - ((eqv? #\; c) - (set! doc-lines (cons (read-cmt-line) doc-lines)) - (body-cmt (peek-char *scheme-source*))) - ((eqv? c #\newline) - (read-char *scheme-source*) - (lp (peek-char *scheme-source*))) - ;; Allow whitespace before ; in doc comments. - ((char-whitespace? c) - (read-char *scheme-source*) - (body-cmt (peek-char *scheme-source*))) - (else - (lp (peek-char *scheme-source*))))) - - ;;Comments incorporated in generated Texinfo files. - ;;Transcribe comments to current position in Texinfo file - ;;until a non-comment line is reached (may be a blank line). - (define (doc-cmt c) - (cond ((eof-object? c) (lp c)) - ((eqv? #\; c) - (out-cmt (read-cmt-line)) - (doc-cmt (peek-char *scheme-source*))) - ((eqv? c #\newline) - (read-char *scheme-source*) - (newline *derived-txi*) - (lp (peek-char *scheme-source*))) - ;; Allow whitespace before ; in doc comments. - ((char-whitespace? c) - (read-char *scheme-source*) - (doc-cmt (peek-char *scheme-source*))) - (else - (newline *derived-txi*) - (lp (peek-char *scheme-source*))))) - (lp (peek-char *scheme-source*)))) + (out-cmt (if (string=? tok "@") + (skip-ws line 1) + line)) + (doc-cmt (peek-char *scheme-source*)))))) + ;; Transcribe the comment line to C source file. + (else + (read-line *scheme-source*) + (lp (peek-char *scheme-source*))))) + + ;;Comments incorporated in generated Texinfo files. + ;;Continue adding lines to DOC-LINES until a non-comment + ;;line is reached (may be a blank line). + (define (body-cmt c) + (cond ((eof-object? c) (lp c)) + ((eqv? #\; c) + (set! doc-lines (cons (read-cmt-line) doc-lines)) + (body-cmt (peek-char *scheme-source*))) + ((eqv? c #\newline) + (read-char *scheme-source*) + (lp (peek-char *scheme-source*))) + ;; Allow whitespace before ; in doc comments. + ((char-whitespace? c) + (read-char *scheme-source*) + (body-cmt (peek-char *scheme-source*))) + (else + (lp (peek-char *scheme-source*))))) + + ;;Comments incorporated in generated Texinfo files. + ;;Transcribe comments to current position in Texinfo file + ;;until a non-comment line is reached (may be a blank line). + (define (doc-cmt c) + (cond ((eof-object? c) (lp c)) + ((eqv? #\; c) + (out-cmt (read-cmt-line)) + (doc-cmt (peek-char *scheme-source*))) + ((eqv? c #\newline) + (read-char *scheme-source*) + (newline *derived-txi*) + (lp (peek-char *scheme-source*))) + ;; Allow whitespace before ; in doc comments. + ((char-whitespace? c) + (read-char *scheme-source*) + (doc-cmt (peek-char *scheme-source*))) + (else + (newline *derived-txi*) + (lp (peek-char *scheme-source*))))) + (lp (peek-char *scheme-source*)))))) (define (schmooz-top-doc-begin def1 defs doc proc-args) (let ((op1 (sexp-def def1))) @@ -586,7 +609,7 @@ (cons (def->var-name (car ss)) smatch))))))))))))) -;;; SCHMOOZ-TOP - schmooz top level form sexp. +;;; SCHMOOZ-TOP - schmooz top level form sexp1 ... (define (schmooz-top sexp1 sexps doc proc-args) (cond ((not (pair? sexp1))) ((pair? sexps) @@ -621,5 +644,5 @@ (or (null? doc) (report "SCHMOOZ: no definition found for Texinfo documentation" - doc sexp)) + doc sexp1)) (set! *procedure* #f)) |