summaryrefslogtreecommitdiffstats
path: root/schmooz.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
commit8466d8cfa486fb30d1755c4261b781135083787b (patch)
treec8c12c67246f543c3cc4f64d1c07e003cb1d45ae /schmooz.scm
parent87b82b5822ca54228cfa6df29be3ad9d4bc47d16 (diff)
downloadslib-8466d8cfa486fb30d1755c4261b781135083787b.tar.gz
slib-8466d8cfa486fb30d1755c4261b781135083787b.zip
Import Upstream version 3a1upstream/3a1
Diffstat (limited to 'schmooz.scm')
-rw-r--r--schmooz.scm403
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))