--- /dev/null
+#| -*-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))
+\f
+(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)))
+\f
+(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)))))
+\f
+(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)))))))))
+\f
+(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))))))
+\f
+(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)))))
+\f
+(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!)
+\f
+(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
projects / mit-scheme.git / commitdiff