From b94f351e4453c7113b53c0d0e31a3ae75fa93e00 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 19 Jan 1991 04:20:36 +0000
Subject: [PATCH] Initial revision

---
 v7/src/rcs/nparse.scm | 462 ++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 462 insertions(+)
 create mode 100644 v7/src/rcs/nparse.scm

diff --git a/v7/src/rcs/nparse.scm b/v7/src/rcs/nparse.scm
new file mode 100644
index 000000000..7d46395a6
--- /dev/null
+++ b/v7/src/rcs/nparse.scm
@@ -0,0 +1,462 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/rcs/nparse.scm,v 1.1 1991/01/19 04:20:36 cph Exp $
+
+Copyright (c) 1991 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; RCS Parser
+
+(declare (usual-integrations))
+
+(define (rcs/read-file filename #!optional text?)
+  (call-with-input-file filename
+    (lambda (port)
+      (parse-rcstext port (if (default-object? text?) true text?)))))
+
+(define (rcs/read-head filename)
+  (call-with-input-file filename
+    (lambda (port)
+      (parse-head (make-line-port port)))))
+
+(define (parse-rcstext port text?)
+  (let ((line-port (make-line-port port)))
+    (let* ((admin (parse-admin line-port))
+	   (deltas (parse-deltas line-port))
+	   (description (parse-desc line-port))
+	   (deltatexts
+	    (if text? (parse-deltatexts line-port (eq? true text?)) '()))
+	   (num->delta (make-delta-map deltas deltatexts text?)))
+      (make-rcstext (and (vector-ref admin 0)
+			 (num->delta (vector-ref admin 0)))
+		    (and (vector-ref admin 1)
+			 (num->delta (vector-ref admin 1)))
+		    (vector-ref admin 2)
+		    (map (lambda (element)
+			   (cons (car element)
+				 (num->delta (cdr element))))
+			 (vector-ref admin 3))
+		    (map (lambda (element)
+			   (cons (car element)
+				 (num->delta (cdr element))))
+			 (vector-ref admin 4))
+		    (vector-ref admin 5)
+		    (vector-ref admin 6)
+		    (vector-ref admin 7)
+		    description))))
+
+(define (make-delta-map deltas deltatexts text?)
+  (let ((table (make-string-hash-table)))
+    (for-each (lambda (delta)
+		(let ((key (vector-ref delta 0)))
+		  (let ((entry (hash-table/get table key false)))
+		    (if entry
+			(error "duplicate delta entry" delta entry)))
+		  (hash-table/put! table key
+				   (make-delta key
+					       (vector-ref delta 1)
+					       (vector-ref delta 2)
+					       (vector-ref delta 3)
+					       (vector-ref delta 4)
+					       (vector-ref delta 5)
+					       false
+					       false))))
+	      deltas)
+    (for-each (lambda (deltatext)
+		(let ((key (vector-ref deltatext 0)))
+		  (let ((delta (hash-table/get table key false)))
+		    (if (not delta)
+			(error "missing delta entry" deltatext))
+		    (set-delta/log! delta (vector-ref deltatext 1))
+		    (set-delta/text! delta (vector-ref deltatext 2)))))
+	      deltatexts)
+    (let ((num->delta
+	   (lambda (key)
+	     (let ((delta (hash-table/get table key false)))
+	       (if (not delta)
+		   (error "unknown delta number" key))
+	       delta))))
+      (hash-table/for-each table
+	(lambda (key delta)
+	  key
+	  (if (and text? (not (delta/log delta)))
+	      (error "missing deltatext entry" delta))
+	  (let loop ((branches (delta/branches delta)))
+	    (if (pair? branches)
+		(begin
+		  (set-car! branches (num->delta (car branches)))
+		  (loop (cdr branches)))))
+	  (let ((next (delta/next delta)))
+	    (if next
+		(set-delta/next! delta (num->delta next))))))
+      num->delta)))
+
+(define (parse-admin line-port)
+  (let* ((head (parse-head line-port))
+	 (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))))
+    (discard-newphrases line-port)
+    (vector 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 true)
+	    (and comment
+		 (not (null? (cdr comment)))
+		 (rcs-string-contents (cadr comment)))
+	    (and expand
+		 (not (null? (cdr expand)))
+		 (rcs-string-contents (cadr expand))))))
+
+(define (parse-head line-port)
+  (let ((head (parse-required line-port "head" '(num))))
+    (and (not (null? (cdr head)))
+	 (rcs-num-string (cadr head)))))
+
+(define (rcs-id-alist symbols)
+  (if (null? symbols)
+      '()
+      (cons (cons (rcs-id-string (car symbols))
+		  (rcs-num-string (caddr symbols)))
+	    (rcs-id-alist (cdddr symbols)))))
+
+(define (parse-deltas 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))
+		   (rcs-date (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-integrable (rcs-date num)
+  (apply date/make (number->integer-list (rcs-num-string num))))
+
+(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 (parse-deltatexts line-port text?)
+  (let loop ()
+    (let ((deltatext (parse-deltatext line-port text?)))
+      (if deltatext
+	  (cons deltatext (loop))
+	  '()))))
+
+(define (parse-deltatext line-port text?)
+  (let ((number (parse-optional line-port 'num '())))
+    (and number
+	 (let ((log (parse-required line-port "log" '(string))))
+	   (let loop ()
+	     (let ((text (parse-optional line-port "text" '(string))))
+	       (if text
+		   (vector (rcs-num-string (car number))
+			   (rcs-string-contents (cadr log))
+			   (and text? (rcs-string-contents (cadr text))))
+		   (begin
+		     (parse-required line-port 'id '(* word))
+		     (loop)))))))))
+
+(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 (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)))))
+
+(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))
+	   ((word) (rcs-word? instance))
+	   (else (error "ill-formed pattern" pattern))))
+	((list? pattern)
+	 (if (null? pattern)
+	     (null? instance)
+	     (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))))))
+
+(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)))
+    (cond ((null? word)
+	   false)
+	  ((rcs-id? word)
+	   (let ((string (rcs-id-string word)))
+	     (if (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 port)
+  (skip-whitespace port)
+  (let ((char (input-port/peek-char port)))
+    (if (eof-object? char)
+	'()
+	((vector-ref parse-word/dispatch-table (char->ascii char)) port))))
+
+(define skip-whitespace
+  (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))))
+
+(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)))
+		 (let ((char (input-port/peek-char port)))
+		   (if (eof-object? char)
+		       (error "end of file while reading string"))
+		   (input-port/discard-char port)
+		   (let ((char* (input-port/peek-char port)))
+		     (if (eq? char char*)
+			 (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)
+
+(define (initialize-dispatch-table!)
+  (set! parse-word/dispatch-table
+	(make-vector 256
+		     (lambda (port)
+		       (error "illegal word-starting character" port))))
+  (subvector-fill! parse-word/dispatch-table #o101 #o133 parse-id)
+  (subvector-fill! parse-word/dispatch-table #o141 #o173 parse-id)
+  (subvector-fill! parse-word/dispatch-table #o300 #o327 parse-id)
+  (subvector-fill! parse-word/dispatch-table #o330 #o366 parse-id)
+  (subvector-fill! parse-word/dispatch-table #o370 #o400 parse-id)
+  (subvector-fill! parse-word/dispatch-table #o060 #o072 parse-num)
+  (vector-set! parse-word/dispatch-table (char->ascii #\@) parse-string)
+  (vector-set! parse-word/dispatch-table (char->ascii #\:) parse-colon)
+  (vector-set! parse-word/dispatch-table (char->ascii #\;) parse-semicolon))
+
+(initialize-dispatch-table!)
+
+(define (rcs-word? object)
+  (and (pair? object)
+       (memq (car object) '(IDENTIFIER STRING NUMBER COLON SEMICOLON))))
+
+(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))))
\ No newline at end of file
-- 
2.25.1