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

;;;; 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)
  #; ;FIXME 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 grammar-name-set!)
  (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 column)  ((grammar-reader grm) grm column))
(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-delimited-parse-grammar-reader delim)
  (lambda (grm column #!optional (port (current-input-port)))
    (prec:parse
      (grammar-read-tab grm)
      delim
      (+ column (flush-input-whitespace port))
      port)) )

;;

(define (grammar-copy! grm1 grm2)
  (grammar-name-set! grm1 (grammar-name grm2))
  (grammar-reader-set! grm1 (grammar-reader grm2))
  (grammar-read-tab-set! grm1 (grammar-read-tab grm2))
  (grammar-writer-set! grm1 (grammar-writer grm2))
  (grammar-read-tab-set! grm1 (grammar-write-tab grm2)) )

(define temporary-grammar
  (let ((+grammar-cache+ (make-grammar #f #f #f #f #f)))
    (lambda (grm)
      (grammar-copy! +grammar-cache+ grm)
      +grammar-cache+ ) ) )

(define (read-delimited-sexp port delim grm column)
  (unless (grammar? grm) (error 'read-delimited-sexp "invalid grammar" grm))
  (let ((tmp (temporary-grammar grm)))
    (grammar-reader-set! tmp (make-delimited-parse-grammar-reader delim))
    (parameterize ((current-input-port port))
      (read-sexp tmp column) ) ) )