From 8466d8cfa486fb30d1755c4261b781135083787b Mon Sep 17 00:00:00 2001
From: Bryan Newbold <bnewbold@robocracy.org>
Date: Mon, 20 Feb 2017 00:05:29 -0800
Subject: Import Upstream version 3a1

---
 schmooz.scm | 403 ++++++++++++++++++++++++++++++++----------------------------
 1 file changed, 213 insertions(+), 190 deletions(-)

(limited to 'schmooz.scm')

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))
-- 
cgit v1.2.3