#| -*-Scheme-*-

$Id: rcsparse.scm,v 1.6 2003/02/14 18:28:13 cph Exp $

Copyright (c) 1991-1999 Massachusetts Institute of Technology

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

MIT/GNU Scheme is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
USA.

|#

;;;; RCS Parser

(declare (usual-integrations))

(define (parse-rcs-admin filename)
  (call-with-input-file filename
    (lambda (port)
      (let* ((line-port (make-line-port port))
	     (head
	      (let ((head (parse-required line-port "head" '(NUM))))
		(and (not (null? (cdr head)))
		     (rcs-num-string (cadr head)))))
	     (branch (parse-optional line-port "branch" '(NUM)))
	     (access-list (parse-required line-port "access" '(* ID)))
	     (symbols (parse-required line-port "symbols" '(* ID COLON NUM)))
	     (locks (parse-required line-port "locks" '(* ID COLON NUM)))
	     (strict (parse-optional line-port "strict" '()))
	     (comment (parse-optional line-port "comment" '(? STRING)))
	     (expand (parse-optional line-port "expand" '(? STRING)))
	     (deltas (parse-deltas line-port))
	     (desc (parse-desc line-port))
	     (num->delta (make-delta-map deltas))
	     (rcs-id-alist
	      (lambda (syms)
		(let loop ((syms syms))
		  (if (null? syms)
		      '()
		      (cons (cons (rcs-id-string (car syms))
				  (num->delta (rcs-num-string (caddr syms))))
			    (loop (cdddr syms))))))))
	(make-rcs-admin (and head (num->delta head))
			(and branch
			     (not (null? (cdr branch)))
			     (rcs-num-string (cadr branch)))
			(map rcs-id-string (cdr access-list))
			(rcs-id-alist (cdr symbols))
			(rcs-id-alist (cdr locks))
			(and strict #t)
			(and comment
			     (not (null? (cdr comment)))
			     (rcs-string-contents (cadr comment)))
			(and expand
			     (not (null? (cdr expand)))
			     (rcs-string-contents (cadr expand)))
			desc)))))

(define-structure (rcs-admin (conc-name rcs-admin/))
  (head #f read-only #t)
  (branch #f read-only #t)
  (access-list #f read-only #t)
  (symbols #f read-only #t)
  (locks #f read-only #t)
  (strict? #f read-only #t)
  (comment #f read-only #t)
  (expand #f read-only #t)
  (description #f read-only #t))

(define (parse-required line-port head tail)
  (let ((line (line-read line-port)))
    (if (not (and (rcs-match head (car line))
		  (rcs-match tail (cdr line))))
	(error "Ill-formed RCS file:" head tail line))
    line))

(define (parse-optional line-port head tail)
  (let ((line (line-peek line-port)))
    (and line
	 (rcs-match head (car line))
	 (begin
	   (line-discard line-port)
	   (if (not (rcs-match tail (cdr line)))
	       (error "Ill-formed RCS file:" head tail line))
	   line))))

(define (make-delta-map deltas)
  (let ((table (make-string-hash-table)))
    (for-each (lambda (delta)
		(let ((key (vector-ref delta 0)))
		  (let ((entry (hash-table/get table key #f)))
		    (if entry
			(error "duplicate delta entry" delta entry)))
		  (hash-table/put! table key
				   (make-rcs-delta key
						   (vector-ref delta 1)
						   (vector-ref delta 2)
						   (vector-ref delta 3)
						   (vector-ref delta 4)
						   (vector-ref delta 5)))))
	      deltas)
    (let ((num->delta
	   (lambda (key)
	     (let ((delta (hash-table/get table key #f)))
	       (if (not delta)
		   (error "unknown delta number" key))
	       delta))))
      (hash-table/for-each table
	(lambda (key delta)
	  key
	  (do ((branches (rcs-delta/branches delta) (cdr branches)))
	      ((null? branches))
	    (set-car! branches (num->delta (car branches))))
	  (let ((next (rcs-delta/next delta)))
	    (if next
		(set-rcs-delta/next! delta (num->delta next))))))
      num->delta)))

(define-structure (rcs-delta (conc-name rcs-delta/))
  (number #f read-only #t)
  (date #f read-only #t)
  (author #f read-only #t)
  (state #f read-only #t)
  (branches #f read-only #t)
  next)

(define (parse-deltas line-port)
  (discard-newphrases line-port)
  (let ((delta (parse-delta line-port)))
    (if delta
	(cons delta (parse-deltas line-port))
	'())))

(define (parse-delta line-port)
  (let ((number (parse-optional line-port 'num '())))
    (and number
	 (let* ((date (parse-required line-port "date" '(num)))
		(author (parse-required line-port "author" '(id)))
		(state (parse-required line-port "state" '(? id)))
		(branches (parse-required line-port "branches" '(* num)))
		(next (parse-required line-port "next" '(? num))))
	   (discard-newphrases line-port)
	   (vector (rcs-num-string (car number))
		   (number->integer-list (rcs-num-string (cadr date)))
		   (rcs-id-string (cadr author))
		   (and (not (null? (cdr state)))
			(rcs-id-string (cadr state)))
		   (map rcs-num-string (cdr branches))
		   (and (not (null? (cdr next)))
			(rcs-num-string (cadr next))))))))

(define (number->integer-list string)
  (let ((end (string-length string)))
    (let loop ((start 0) (index 0))
      (cond ((= index end)
	     (if (= start end)
		 (error "Trailing decimal in number"))
	     (list (string->number (substring string start end))))
	    ((char=? #\. (string-ref string index))
	     (cons (string->number (substring string start index))
		   (let ((start (1+ index)))
		     (loop start start))))
	    (else
	     (loop start (1+ index)))))))

(define (parse-desc line-port)
  (rcs-string-contents (cadr (parse-required line-port "desc" '(string)))))

(define (discard-newphrases line-port)
  (let ((line (line-peek line-port)))
    (if (and line
	     (rcs-match 'id (car line))
	     (not (string=? "desc" (rcs-id-string (car line))))
	     (rcs-match '(* word) (cdr line)))
	(begin
	  (line-discard line-port)
	  (discard-newphrases line-port)))))

;;;; Delta Search

(define (rcs-find-delta admin number error?)
  (if number
      (let ((n-fields (rcs-number-length number))
	    (head (rcs-admin/head admin)))
	(if (fix:= n-fields 1)
	    (let loop ((delta head))
	      (if delta
		  (if (string-prefix? number (rcs-delta/number delta))
		      delta
		      (loop (rcs-delta/next delta)))
		  (and error?
		       (error:bad-range-argument number 'RCS-FIND-DELTA))))
	    (let loop ((branch head) (i 1))
	      (let* ((i (fix:+ i 1))
		     (delta
		      (find-revision branch
				     (rcs-number-head number i error?)
				     error?)))
		(and delta
		     (if (fix:= n-fields i)
			 delta
			 (let* ((i (fix:+ i 1))
				(branch
				 (find-branch delta
					      (rcs-number-head number i error?)
					      error?)))
			   (and branch
				(if (fix:= n-fields i)
				    (last-revision branch)
				    (loop branch i))))))))))
      (if (rcs-admin/branch admin)
	  (rcs-find-delta admin (rcs-admin/branch admin) error?)
	  (rcs-admin/head admin))))

(define (last-revision delta)
  (if (rcs-delta/next delta)
      (last-revision (rcs-delta/next delta))
      delta))

(define (find-revision delta number error?)
  (and number
       (let loop ((delta delta))
	 (if delta
	     (if (string=? number (rcs-delta/number delta))
		 delta
		 (loop (rcs-delta/next delta)))
	     (and error?
		  (error:bad-range-argument number 'RCS-FIND-DELTA))))))

(define (find-branch delta number error?)
  (and number
       (let loop ((branches (rcs-delta/branches delta)))
	 (if (not (null? branches))
	     (if (string-prefix? number (rcs-delta/number (car branches)))
		 (car branches)
		 (loop (cdr branches)))
	     (and error?
		  (error:bad-range-argument number 'RCS-FIND-DELTA))))))

(define (rcs-number-head number n-fields error?)
  (let ((end (string-length number)))
    (let loop ((i 0) (n-fields n-fields))
      (if (fix:= i end)
	  (if (fix:> n-fields 1)
	      (and error?
		   (error:bad-range-argument n-fields 'RCS-FIND-DELTA))
	      number)
	  (let ((i* (fix:+ i 1)))
	    (if (char=? #\. (string-ref number i))
		(let ((n-fields (fix:- n-fields 1)))
		  (if (fix:= n-fields 0)
		      (if (fix:= i* end)
			  number
			  (string-head number i))
		      (loop i* n-fields)))
		(loop i* n-fields)))))))

(define (rcs-number-length number)
  (let ((end (string-length number)))
    (do ((i 0 (fix:+ i 1))
	 (n-fields 1
		   (if (char=? #\. (string-ref number i))
		       (fix:+ n-fields 1)
		       n-fields)))
	((fix:= i end) n-fields))))

;;;; Matcher for Tokenized Input

(define (rcs-match pattern instance)
  (cond ((string? pattern)
	 (and (rcs-id? instance)
	      (string=? pattern (rcs-id-string instance))))
	((symbol? pattern)
	 (case pattern
	   ((ID) (rcs-id? instance))
	   ((STRING) (rcs-string? instance))
	   ((NUM) (rcs-num? instance))
	   ((COLON) (rcs-colon? instance))
	   ((SEMICOLON) (rcs-semicolon? instance))
	   (else (error "Ill-formed pattern:" pattern))))
	((null? pattern)
	 (null? instance))
	((list? pattern)
	 (case (car pattern)
	   ((?)
	    (or (null? instance)
		(rcs-match-list (cdr pattern) instance null?)))
	   ((*)
	    (let loop ((instance instance))
	      (or (null? instance)
		  (rcs-match-list (cdr pattern) instance loop))))
	   ((+)
	    (letrec
		((loop
		  (lambda (instance)
		    (or (null? instance)
			(rcs-match-list (cdr pattern) instance loop)))))
	      (rcs-match-list (cdr pattern) instance loop)))
	   (else
	    (rcs-match-list pattern instance null?))))
	(else
	 (error "Ill-formed pattern:" pattern))))

(define (rcs-match-list pattern instance if-match)
  (let loop ((pattern pattern) (instance instance))
    (if (null? pattern)
	(if-match instance)
	(and (pair? instance)
	     (rcs-match (car pattern) (car instance))
	     (loop (cdr pattern) (cdr instance))))))

;;;; Tokenizer

(define (make-line-port port)
  (cons 'EMPTY port))

(define (line-peek line-port)
  (if (eq? 'EMPTY (car line-port))
      (set-car! line-port (parse-line (cdr line-port))))
  (car line-port))

(define (line-discard line-port)
  (if (car line-port)
      (set-car! line-port 'EMPTY)))

(define (line-read line-port)
  (let ((line (line-peek line-port)))
    (line-discard line-port)
    line))

(define (parse-line port)
  (let ((word (parse-word port)))
    (and word
	 (cond ((rcs-id? word)
		(if (let ((string (rcs-id-string word)))
		      (or (string=? "desc" string)
			  (string=? "log" string)
			  (string=? "text" string)))
		    (let ((string (parse-word port)))
		      (if (not (rcs-string? string))
			  (error "Illegal word sequence:" word string))
		      (list word string))
		    (cons word
			  (let loop ()
			    (let ((word (parse-word port)))
			      (if (rcs-semicolon? word)
				  '()
				  (cons word (loop))))))))
	       ((rcs-num? word)
		(list word))
	       (else
		(error "Illegal line-starting word:" word))))))

(define parse-word
  (let ((delimiters
	 (char-set-invert
	  (char-set-union (ascii-range->char-set #o010 #o016)
			  (ascii-range->char-set #o040 #o041)))))
    (lambda (port)
      (input-port/discard-chars port delimiters)
      (let ((char (input-port/peek-char port)))
	(and (not (eof-object? char))
	     ((vector-ref parse-word/dispatch-table (char->integer char))
	      port))))))

(define parse-string
  (let ((delimiters (char-set #\@)))
    (lambda (port)
      (input-port/discard-char port)
      (let ((strings
	     (let loop ()
	       (let ((head (input-port/read-string port delimiters)))
		 (if (eof-object? (input-port/peek-char port))
		     (error "End of file while reading string."))
		 (input-port/discard-char port)
		 (if (char=? #\@ (input-port/peek-char port))
		     (begin
		       (input-port/discard-char port)
		       (cons head (cons "@" (loop))))
		     (list head))))))
	(make-rcs-string
	 (if (null? (cdr strings))
	     (car strings)
	     (apply string-append strings)))))))

(define parse-id
  (let ((delimiters
	 (char-set-invert
	  (char-set-difference
	   (char-set-union (ascii-range->char-set #o041 #o177)
			   (ascii-range->char-set #o240 #o400))
	   (char-set #\$ #\, #\. #\: #\; #\@)))))
    (lambda (port)
      (make-rcs-id (input-port/read-string port delimiters)))))

(define parse-num
  (let ((delimiters
	 (char-set-invert (char-set-union char-set:numeric (char-set #\.)))))
    (lambda (port)
      (make-rcs-num (input-port/read-string port delimiters)))))

(define (parse-colon port)
  (input-port/discard-char port)
  (make-rcs-colon))

(define (parse-semicolon port)
  (input-port/discard-char port)
  (make-rcs-semicolon))

(define parse-word/dispatch-table
  (let ((table
	 (make-vector 256
		      (lambda (port)
			port
			(error "Illegal word-starting character.")))))
    (subvector-fill! table #o101 #o133 parse-id)
    (subvector-fill! table #o141 #o173 parse-id)
    (subvector-fill! table #o300 #o327 parse-id)
    (subvector-fill! table #o330 #o366 parse-id)
    (subvector-fill! table #o370 #o400 parse-id)
    (subvector-fill! table #o060 #o072 parse-num)
    (vector-set! table (char->integer #\@) parse-string)
    (vector-set! table (char->integer #\:) parse-colon)
    (vector-set! table (char->integer #\;) parse-semicolon)
    table))

;;;; Tokens

(define-integrable (make-rcs-id string)
  (cons 'IDENTIFIER string))

(define (rcs-id? word)
  (and (pair? word)
       (eq? 'IDENTIFIER (car word))))

(define-integrable (rcs-id-string rcs-id)
  (cdr rcs-id))

(define-integrable (make-rcs-string contents)
  (cons 'STRING contents))

(define (rcs-string? word)
  (and (pair? word)
       (eq? 'STRING (car word))))

(define-integrable (rcs-string-contents rcs-string)
  (cdr rcs-string))

(define-integrable (make-rcs-num string)
  (cons 'NUMBER string))

(define (rcs-num? word)
  (and (pair? word)
       (eq? 'NUMBER (car word))))

(define-integrable (rcs-num-string rcs-num)
  (cdr rcs-num))

(define-integrable (make-rcs-colon)
  '(COLON))

(define (rcs-colon? word)
  (and (pair? word)
       (eq? 'COLON (car word))))

(define-integrable (make-rcs-semicolon)
  '(SEMICOLON))

(define (rcs-semicolon? word)
  (and (pair? word)
       (eq? 'SEMICOLON (car word))))