From: Matt Wette 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.") ;; ( (@ ) ) ;; @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