source: project/release/5/slib-prec/trunk/slib-grammar.scm @ 38598

;;;; slib-grammar.scm

;
(define *grammar-ids* '())

(define (grammar-id-name-set! id name)
  (set! *grammar-ids* (alist-update! id name *grammar-ids* eqv?)) )

(define (grammar-id-name id)
  (alist-ref id *grammar-ids* eqv?) )

(define (list-of-grammar-ids)
  (map car *grammar-ids*) )

(define (count-of-grammar-ids)
  (length *grammar-ids*) )

(define (clear-grammar-ids)
  (set! *grammar-ids* '()) )

;ordered list of grammar names
(define (grammar-id-name-setup! names)
  (import (only (srfi 1) iota))
  (for-each grammar-id-name-set! (iota (length names)) names) )

;;

;;from jacal unparse.scm
(define (print-using-grammar sexp grm)
  ;(print "[" (grammar-name grm) "] " sexp)
  (pretty-print sexp)
  #; ;needs most of jacal!
  (template-print sexp (grammar-write-tab grm)) )

; supplies module based struct tag & other identifiers
(define-record grammar name reader read-tab writer write-tab)
(define-record-type grammar
  (make-grammar name reader read-tab writer write-tab)
  grammar?
  (name grammar-name)
  (reader grammar-reader grammar-reader-set!)
  (read-tab grammar-read-tab grammar-read-tab-set!)
  (writer grammar-writer grammar-writer-set!)
  (write-tab grammar-write-tab grammar-read-tab-set!) )

;
(define *grammars* '())

(define (defgrammar name grm)
  (set! *grammars* (alist-update! name grm *grammars* eq?)) )

(define (get-grammar name)
  (alist-ref name *grammars* eq?) )

(define (list-of-grammars)
  (map (lambda (cell) (car cell)) *grammars*) )

(define (count-of-grammars)
  (length *grammars*) )

(define (get-grammar/id id)
  (get-grammar (grammar-id-name id)) )

(define (clear-grammars)
  (clear-grammar-ids)
  (set! *grammar* '()) )

;
(define (read-sexp grm icol) ((grammar-reader grm) grm icol))
(define (write-sexp sexp grm) ((grammar-writer grm) sexp grm))

(define *tab-stop* 8)

;
(define (flush-input-whitespace port)
  (do ((chr (peek-char port) (peek-char port))
       (col 0 (case chr
                ((#\space)    (+ 1 col))
                ((#\tab)      (modulo (+ (sub1 *tab-stop*) col) *tab-stop*))
                ((#\newline)  0)
                (else         col))))
      ((or (eof-object? chr)
           (not (char-whitespace? chr)))
       col)
    (read-char port)))

;;

;
(define (make-grm-parse-reader delim #!optional (port (current-input-port)))
  (lambda (grm column)
    (prec:parse
      (grammar-read-tab grm)
      delim
      (+ column (flush-input-whitespace port))
      port)) )

(define (read-sexp/delim grm delim port)
  (unless (grammar? grm) (error 'read-sexp/delim "invalid grammar" grm))
  (let (
    (tmp (grammar-reader grm)) )
    (grammar-reader-set! grm (make-grm-parse-reader delim port))
    (let (
      (res (read-sexp grm 0)) )
      (grammar-reader-set! grm tmp)
      res ) ) )