From: Matt Wette <mwette@nautilus.championbroadband.com>
Date: Sat, 3 Dec 2016 15:19:35 +0000 (-0800)
Subject: nyacc: multiple fixes
X-Git-Tag: v0.6~276
X-Git-Url: https://jxself.org/git/?p=mes.git;a=commitdiff_plain;h=4c4706f17e6bed8c8a5dcba34c2fea096fb463ec

nyacc: multiple fixes
---

diff --git a/module/nyacc/lang/util.scm b/module/nyacc/lang/util.scm
index 5d3f719e..e22c0b21 100644
--- a/module/nyacc/lang/util.scm
+++ b/module/nyacc/lang/util.scm
@@ -9,20 +9,20 @@
 ;; runtime utilities for the parsers -- needs work
 
 (define-module (nyacc lang util)
-  #:export (lang-crn-lic
-	    push-input pop-input reset-input-stack
-	    make-tl tl->list ;; rename?? to tl->sx for sxml-expr
-	    tl-append tl-insert tl-extend tl+attr
-	    sx-tag
-	    sx-attr sx-attr-ref sx-has-attr? sx-set-attr! sx-set-attr*
-	    sx-ref sx-tail sx-find
-	    ;; for pretty-printing
-	    make-protect-expr make-pp-formatter make-pp-formatter/ugly
-	    ;; for ???
-	    move-if-changed
-            fmterr)
-  #:use-module ((srfi srfi-1) #:select(find))
-  )
+#:export (lang-crn-lic
+    push-input pop-input reset-input-stack
+    make-tl tl->list ;; rename?? to tl->sx for sxml-expr
+    tl-append tl-insert tl-extend tl+attr
+    sx-tag
+    sx-attr sx-attr-ref sx-has-attr? sx-set-attr! sx-set-attr*
+    sx-ref sx-tail sx-find
+    ;; for pretty-printing
+    make-protect-expr make-pp-formatter make-pp-formatter/ugly
+    ;; for ???
+    move-if-changed
+    fmterr)
+#:use-module ((srfi srfi-1) #:select(find))
+)
 
 (cond-expand
  (guile-2)
@@ -40,38 +40,38 @@ or any later version published by the Free Software Foundation.  See the
 file COPYING included with the this distribution.")
 
 (define (fmterr fmt . args)
-  (apply simple-format (current-error-port) fmt args))
+(apply simple-format (current-error-port) fmt args))
 
 ;; === input stack =====================
 
 (define *input-stack* (make-fluid '()))
 
 (define (reset-input-stack)
-  (fluid-set! *input-stack* '()))
+(fluid-set! *input-stack* '()))
 
 (define (push-input port)
-  (let ((curr (current-input-port))
-	(ipstk (fluid-ref *input-stack*)))
-    (fluid-set! *input-stack* (cons curr ipstk))
-    (set-current-input-port port)))
+(let ((curr (current-input-port))
+(ipstk (fluid-ref *input-stack*)))
+(fluid-set! *input-stack* (cons curr ipstk))
+(set-current-input-port port)))
 
 ;; Return #f if empty
 (define (pop-input)
-  (let ((ipstk (fluid-ref *input-stack*)))
-    (if (null? ipstk) #f
-	(begin
-	  (set-current-input-port (car ipstk))
-	  (fluid-set! *input-stack* (cdr ipstk))))))
+(let ((ipstk (fluid-ref *input-stack*)))
+(if (null? ipstk) #f
+(begin
+  (set-current-input-port (car ipstk))
+  (fluid-set! *input-stack* (cdr ipstk))))))
 
 ;; It may be possible to reimplement with closures, using soft-ports.
 ;; (push-string-input ...
 
 #|
 (define (push-string-input str)
-  (let* ((prev (current-input-port))
-	 (port (make-soft-port ...))
-	 )
-    #f))
+(let* ((prev (current-input-port))
+ (port (make-soft-port ...))
+ )
+#f))
 |#
 
 ;; === tl ==============================
@@ -90,9 +90,9 @@ file COPYING included with the this distribution.")
 ;; @deffn make-tl tag [item item ...]
 ;; Create a tagged-list structure.
 (define (make-tl tag . rest)
-  (let iter ((tail tag) (l rest))
-    (if (null? l) (cons '() tail)
-	(iter (cons (car l) tail) (cdr l)))))
+(let iter ((tail tag) (l rest))
+(if (null? l) (cons '() tail)
+(iter (cons (car l) tail) (cdr l)))))
 
 ;; @deffn tl->list tl
 ;; Convert a tagged list structure to a list.  This collects added attributes
@@ -101,37 +101,37 @@ file COPYING included with the this distribution.")
 ;; (<tag> (@ <attr>) <rest>)
 ;; @end example
 (define (tl->list tl)
-  (let ((heda (car tl))
-	(head (let iter ((head '()) (attr '()) (tl-head (car tl)))
-		(if (null? tl-head)
-		    (if (pair? attr)
-			(cons (cons '@ attr) (reverse head))
-			(reverse head))
-		    (if (and (pair? (car tl-head)) (eq? '@ (caar tl-head)))
-			(iter head (cons (cdar tl-head) attr) (cdr tl-head))
-			(iter (cons (car tl-head) head) attr (cdr tl-head)))))))
-    (let iter ((tail '()) (tl-tail (cdr tl)))
-      (if (pair? tl-tail)
-	  (iter (cons (car tl-tail) tail) (cdr tl-tail))
-	  (cons tl-tail (append head tail))))))
+(let ((heda (car tl))
+(head (let iter ((head '()) (attr '()) (tl-head (car tl)))
+	(if (null? tl-head)
+	    (if (pair? attr)
+		(cons (cons '@ attr) (reverse head))
+		(reverse head))
+	    (if (and (pair? (car tl-head)) (eq? '@ (caar tl-head)))
+		(iter head (cons (cdar tl-head) attr) (cdr tl-head))
+		(iter (cons (car tl-head) head) attr (cdr tl-head)))))))
+(let iter ((tail '()) (tl-tail (cdr tl)))
+(if (pair? tl-tail)
+  (iter (cons (car tl-tail) tail) (cdr tl-tail))
+  (cons tl-tail (append head tail))))))
 
 ;; @deffn tl-insert tl item
 ;; Insert item at front of tagged list (but after tag).
 (define (tl-insert tl item)
-  (cons (cons item (car tl)) (cdr tl)))
+(cons (cons item (car tl)) (cdr tl)))
 
 ;; @deffn tl-append tl item ...
 ;; Append item at end of tagged list.
 (define (tl-append tl . rest)
-  (cons (car tl)
-	(let iter ((tail (cdr tl)) (items rest))
-	  (if (null? items) tail
-	      (iter (cons (car items) tail) (cdr items))))))
+(cons (car tl)
+(let iter ((tail (cdr tl)) (items rest))
+  (if (null? items) tail
+      (iter (cons (car items) tail) (cdr items))))))
 
 ;; @deffn tl-extend tl item-l
 ;; Extend with a list of items.
 (define (tl-extend tl item-l)
-  (apply tl-append tl item-l))
+(apply tl-append tl item-l))
 
 ;; @deffn tl+attr tl key val)
 ;; Add an attribute to a tagged list.  Return the tl.
@@ -139,13 +139,13 @@ file COPYING included with the this distribution.")
 ;; (tl+attr tl 'type "int")
 ;; @end example
 (define (tl+attr tl key val)
-  (tl-insert tl (cons '@ (list key val))))
+(tl-insert tl (cons '@ (list key val))))
 
 ;; @deffn tl-merge tl tl1
 ;; Merge guts of phony-tl @code{tl1} into @code{tl}.
 (define (tl-merge tl tl1)
-  (error "not implemented (yet)")
-  )
+(error "not implemented (yet)")
+)
 
 ;; === sx ==============================
 ;; @section SXML Utility Procedures
@@ -158,73 +158,73 @@ file COPYING included with the this distribution.")
 ;; (sx-ref '(abc (@ (foo "1")) "def") 1) => "def"
 ;; @end example
 (define (sx-ref sx ix)
-  (define (list-xref l x) (if (> (length l) x) (list-ref l x) #f))
-  (cond
-   ((zero? ix) (car sx))
-   ((and (pair? (cadr sx)) (eqv? '@ (caadr sx)))
-    (list-xref sx (1+ ix)))
-   (else
-    (list-xref sx ix))))
+(define (list-xref l x) (if (> (length l) x) (list-ref l x) #f))
+(cond
+((zero? ix) (car sx))
+((and (pair? (cadr sx)) (eqv? '@ (caadr sx)))
+(list-xref sx (1+ ix)))
+(else
+(list-xref sx ix))))
 
 ;; @deffn sx-tag sx => tag
 ;; Return the tag for a tree
 (define (sx-tag sx)
-  (if (pair? sx) (car sx) #f))
+(if (pair? sx) (car sx) #f))
 
 ;; @deffn sx-tail sx ix => (list)
 ;; Return the tail starting at the ix-th cdr, starting from 0.
 ;; For example, if sx has 3 items then (sx-tail sx 2) returns '().
 ;; BUG: not working for (sx '(foo) 1)
 (define (sx-tail sx ix)
-  (if (zero? ix) (error "zero index not supported"))
-  (let ((sx (cdr sx)) (ix (1- ix)))
-    (cond
-     ((and (null? sx) (zero? ix)) sx)
-     ((and (pair? (car sx)) (eqv? '@ (caar sx))) (list-tail sx (1+ ix)))
-     (else (list-tail sx ix)))))
+(if (zero? ix) (error "zero index not supported"))
+(let ((sx (cdr sx)) (ix (1- ix)))
+(cond
+((and (null? sx) (zero? ix)) sx)
+((and (pair? (car sx)) (eqv? '@ (caar sx))) (list-tail sx (1+ ix)))
+(else (list-tail sx ix)))))
 
 ;; @deffn sx-has-attr? sx
 ;; p to determine if @arg{sx} has attributes.
 (define (sx-has-attr? sx)
-  (and (pair? (cdr sx)) (pair? (cadr sx)) (eqv? '@ (caadr sx))))
+(and (pair? (cdr sx)) (pair? (cadr sx)) (eqv? '@ (caadr sx))))
 
 ;; @deffn sx-attr sx => '(@ ...)|#f
 ;; @example
 ;; (sx-attr '(abc (@ (foo "1")) def) 1) => '(@ (foo "1"))
 ;; @end example
 (define (sx-attr sx)
-  (if (and (pair? (cdr sx)) (pair? (cadr sx)))
-      (if (eqv? '@ (caadr sx))
-	  (cadr sx)
-	  #f)
-      #f))
+(if (and (pair? (cdr sx)) (pair? (cadr sx)))
+(if (eqv? '@ (caadr sx))
+  (cadr sx)
+  #f)
+#f))
 
 ;; @deffn sx-attr-ref sx key => val
 ;; Return an attribute value given the key, or @code{#f}.
 (define (sx-attr-ref sx key)
-  (and=> (sx-attr sx)
-	 (lambda (attr)
-	   (and=> (assq-ref (cdr attr) key) car))))
+(and=> (sx-attr sx)
+ (lambda (attr)
+   (and=> (assq-ref (cdr attr) key) car))))
 
 ;; @deffn sx-set-attr! sx key val
 ;; Set attribute for sx.  If no attributes exist, if key does not exist,
 ;; add it, if it does exist, replace it.
 (define (sx-set-attr! sx key val . rest)
-  (if (sx-has-attr? sx)
-      (let ((attr (cadr sx)))
-	(set-cdr! attr (assoc-set! (cdr attr) key (list val))))
-      (set-cdr! sx (cons `(@ (,key ,val)) (cdr sx))))
-  sx)
+(if (sx-has-attr? sx)
+(let ((attr (cadr sx)))
+(set-cdr! attr (assoc-set! (cdr attr) key (list val))))
+(set-cdr! sx (cons `(@ (,key ,val)) (cdr sx))))
+sx)
 
 ;; @deffn sx-set-attr* sx key val [key val [key ... ]]
 ;; Set attribute for sx.  If no attributes exist, if key does not exist,
 ;; add it, if it does exist, replace it.
 (define (sx-set-attr* sx . rest)
-  (let iter ((attr (or (and=> (sx-attr sx) cdr) '())) (kvl rest))
-    (cond
-     ((null? kvl) (cons* (sx-tag sx) (cons '@ (reverse attr)) (sx-tail sx 1)))
-     (else (iter (cons (list (car kvl) (cadr kvl)) attr) (cddr kvl))))))
-      
+(let iter ((attr (or (and=> (sx-attr sx) cdr) '())) (kvl rest))
+(cond
+((null? kvl) (cons* (sx-tag sx) (cons '@ (reverse attr)) (sx-tail sx 1)))
+(else (iter (cons (list (car kvl) (cadr kvl)) attr) (cddr kvl))))))
+
 ;; @deffn sx-find tag sx => ((tag ...) (tag ...))
 ;; Find the first matching element (in the first level).
 (define (sx-find tag sx)
@@ -315,13 +315,14 @@ file COPYING included with the this distribution.")
 	(lambda (fmt . args)
 	  (let* ((str (apply simple-format #f fmt args))
 		 (len (string-length str)))
-	    (when (zero? column)
+	    (cond
+	     ((zero? column)
 	      (display (ind-str))
 	      (set! column (+ column ind-len)))
-	    (when (> (+ column len) maxcol)
+	     ((> (+ column len) maxcol)
 	      (newline)
 	      (display (cnt-str))
-	      (set! column (+ column ind-len 4)))
+	      (set! column (+ column ind-len 4))))
 	    (display str)
 	    (when (and (positive? len)
 		       (eqv? #\newline (string-ref str (1- len))))
@@ -329,6 +330,7 @@ file COPYING included with the this distribution.")
 
     (lambda (arg0 . rest)
       (cond
+       ;;((string? arg0) (if (> (string-length arg0) 0) (apply sf arg0 rest)))
        ((string? arg0) (apply sf arg0 rest))
        ((eqv? 'push arg0) (push-il))
        ((eqv? 'pop arg0) (pop-il))
@@ -348,6 +350,7 @@ file COPYING included with the this distribution.")
 	     (let* ((str (apply simple-format #f fmt args))
 		    (len (string-length str)))
 	       (cond
+		((zero? len) #t)
 		((char=? #\# (string-ref str 0))
 		 (display str))
 		(else