From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 7 Mar 1997 23:31:22 +0000 (+0000)
Subject: Initial revision
X-Git-Tag: 20090517-FFI~5242
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=12e7ce62c03eb176aa95fbcadc00c554c432d7d5;p=mit-scheme.git

Initial revision
---

diff --git a/v7/src/edwin/comatch.scm b/v7/src/edwin/comatch.scm
new file mode 100644
index 000000000..7f4cca7a0
--- /dev/null
+++ b/v7/src/edwin/comatch.scm
@@ -0,0 +1,166 @@
+;;; -*-Scheme-*-
+;;;
+;;;	$Id: comatch.scm,v 1.1 1997/03/07 23:31:09 cph Exp $
+;;;
+;;;	Copyright (c) 1997 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.
+;;;
+;;; NOTE: Parts of this program (Edwin) were created by translation
+;;; from corresponding parts of GNU Emacs.  Users should be aware that
+;;; the GNU GENERAL PUBLIC LICENSE may apply to these parts.  A copy
+;;; of that license should have been included along with this file.
+;;;
+
+;;;; Combinatoric Matcher
+
+(declare (usual-integrations))
+
+;;; This matcher allows compex matching patterns to be built up from
+;;; primitives using combinators.  With this implementation, the
+;;; patterns are just procedures, but it is simple to change the
+;;; implementation so that they use a different representation.
+
+;;; Each pattern takes two arguments: a start mark and an end mark.
+;;; The pattern matches itself against the buffer's contents between
+;;; the two marks.  A successful match returns a mark to the right of
+;;; the rightmost character in the match.  A failed match returns #F.
+
+(define (comatch-apply comatcher start #!optional end)
+  (comatcher start
+	     (if (default-object? end) (group-end start) end)))
+
+(define (comatch:general procedure) procedure)
+
+(define comatch:false (comatch:general (lambda (start end) start end #f)))
+(define comatch:true (comatch:general (lambda (start end) end start)))
+
+(define comatch:to-sexp (comatch:general forward-to-sexp-start))
+(define comatch:sexp (comatch:general forward-one-sexp))
+
+(define (comatch:char char #!optional case-fold?)
+  (if (or (default-object? case-fold?) (not case-fold?))
+      (comatch:general
+       (lambda (start end)
+	 (and (mark< start end)
+	      (char=? char (extract-right-char start)))))
+      (comatch:general
+       (lambda (start end)
+	 (and (mark< start end)
+	      (char-ci=? char (extract-right-char start)))))))
+
+(define (comatch:string string #!optional case-fold?)
+  (let ((case-fold? (if (default-object? case-fold?) #f case-fold?)))
+    (comatch:general
+     (lambda (start end)
+       (match-forward string start end case-fold?)))))
+
+(define (comatch:regexp regexp #!optional case-fold?)
+  (let ((regexp
+	 (if (compiled-regexp? regexp)
+	     regexp
+	     (re-compile-pattern regexp
+				 (if (default-object? case-fold?)
+				     #f
+				     case-fold?)))))
+    (comatch:general
+     (lambda (start end)
+       (re-match-forward regexp start end)))))
+
+(define (comatch:skip-chars pattern)
+  (comatch:general
+   (lambda (start end)
+     (skip-chars-forward pattern start end))))
+
+;;;; Combinators
+
+(define (comatch:* comatcher)
+  (comatch:general
+   (lambda (start end)
+     (let loop ((start start))
+       (let ((mark (comatch-apply comatcher start end)))
+	 (if mark
+	     (loop mark)
+	     start))))))
+
+(define (comatch:+ comatcher)
+  (let ((tail (comatch:* comatcher)))
+    (comatch:general
+     (lambda (start end)
+       (let ((mark (comatch-apply comatcher start end)))
+	 (and mark
+	      (tail mark end)))))))
+
+(define (comatch:? comatcher)
+  (comatch:general
+   (lambda (start end)
+     (or (comatch-apply comatcher start end) start))))
+
+(define (comatch:combine-rest initial combine-2)
+  (lambda comatchers
+    (if (null? comatchers)
+	initial
+	(let loop ((comatchers comatchers))
+	  (if (null? (cdr comatchers))
+	      (car comatchers)
+	      (combine-2 (car comatchers) (loop (cdr comatchers))))))))
+
+(define comatch:append
+  (comatch:combine-rest comatch:true
+    (lambda (c1 c2)
+      (comatch:general
+       (lambda (start end)
+	 (let ((start (comatch-apply c1 start end)))
+	   (and start
+		(comatch-apply c2 start end))))))))
+
+(define comatch:or
+  (comatch:combine-rest comatch:true
+    (lambda (c1 c2)
+      (comatch:general
+       (lambda (start end)
+	 (or (comatch-apply c1 start end)
+	     (comatch-apply c2 start end)))))))
+
+(define comatch:and
+  (comatch:combine-rest comatch:true
+    (lambda (c1 c2)
+      (comatch:general
+       (lambda (start end)
+	 (and (comatch-apply c1 start end)
+	      (comatch-apply c2 start end)))))))
+
+;;; Edwin Variables:
+;;; scheme-environment: '(edwin)
+;;; scheme-syntax-table: edwin-syntax-table
+;;; End:
diff --git a/v7/src/edwin/keyparse.scm b/v7/src/edwin/keyparse.scm
new file mode 100644
index 000000000..0b24e5739
--- /dev/null
+++ b/v7/src/edwin/keyparse.scm
@@ -0,0 +1,483 @@
+;;; -*-Scheme-*-
+;;;
+;;;	$Id: keyparse.scm,v 1.1 1997/03/07 23:31:15 cph Exp $
+;;;
+;;;	Copyright (c) 1996-97 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.
+;;;
+;;; NOTE: Parts of this program (Edwin) were created by translation
+;;; from corresponding parts of GNU Emacs.  Users should be aware that
+;;; the GNU GENERAL PUBLIC LICENSE may apply to these parts.  A copy
+;;; of that license should have been included along with this file.
+;;;
+
+;;;; Keyword Syntax Parser
+
+(declare (usual-integrations))
+
+(define-structure (description
+		   (keyword-constructor make-keyparser-description)
+		   (conc-name description/))
+  ;; A list of patterns describing the syntax structures recognized by
+  ;; this language.  The patterns are matched left to right.
+  (patterns #f read-only #t)
+
+  ;; A list of "leaders" that can appear at the beginning of a
+  ;; statement.  These leaders are considered to be part of the
+  ;; statement that follows them, and are skipped over to find the
+  ;; statement and parse it.  Each entry in the list is a pair of a
+  ;; regular expression and a procedure; the regexp matches the
+  ;; beginning of the leader, and the procedure skips over the rest of
+  ;; the leader.  The procedure gets two arguments: the result of the
+  ;; regexp match and the END mark, and returns a mark pointing at the
+  ;; end of the leader, or #F if the leader doesn't end by END.
+  (statement-leaders #f read-only #t)
+
+  ;; A procedure that finds the end of a simple statement given two
+  ;; marks: the beginning of the statement and the end of the parse.
+  ;; Returns a mark pointing past the statement end, or #F if the
+  ;; statement doesn't terminate prior to the parse end.
+  (find-statement-end #f read-only #t)
+
+  ;; Procedures that compute the correct indentation for continued
+  ;; objects.  Each procedure accepts a mark pointing to the beginning
+  ;; of the continued object and returns the indentation for
+  ;; continuation lines of that object.
+  (indent-continued-statement #f read-only #t)
+  (indent-continued-comment #f read-only #t))
+
+;; A structure pattern is a list of pattern fragments, which define
+;; the parts of the structure.  The START and END define how the
+;; structure begins and ends.  The CONTINUATIONS define intermediate
+;; keywords that introduce new subsections of the structure.
+
+;; For example, in a VHDL "IF" statement, the START is "IF
+;; <expression> THEN <statements>", the END is "END IF;", and the
+;; continations are "ELSIF <expression> THEN <statements>" and "ELSE
+;; <statements>".
+
+(define-integrable (pattern/start pattern) (car pattern))
+(define-integrable (pattern/end pattern) (cadr pattern))
+(define-integrable (pattern/continuations pattern) (cddr pattern))
+
+;; A pattern fragment is a header followed by an indented body.  (This
+;; is sometimes called a "hanging indentation" style.)  The pattern
+;; fragment defines how to identify the header, how to parse it once
+;; it is identified, how much to indent the header should it span
+;; multiple lines, and how to parse and indent the body.
+
+(define-structure (fragment
+		   (keyword-constructor make-keyparser-fragment)
+		   (conc-name fragment/))
+  ;; Keyword that introduces the structure.
+  (keyword #f read-only #t)
+
+  ;; Procedure that matches the header.  The procedure accepts as
+  ;; argument a mark immediately to the right of the keyword, and
+  ;; returns a boolean indicating whether the header is matched.  If
+  ;; MATCH-HEADER is #F, the header is assumed to be matched when the
+  ;; keyword is recognized.
+  (match-header #f read-only #t)
+
+  ;; Parser to scan over the header of the structure.  A procedure
+  ;; that accepts three arguments and returns one value.  The three
+  ;; arguments are: a parser description, a start mark, and an end
+  ;; mark.  The value is a mark pointing to the end of the header.
+  (parse-header #f read-only #t)
+
+  ;; Procedure that computes the indentation for continuation lines of
+  ;; the header.  The procedure accepts one argument, a mark pointing
+  ;; to the beginning of the header, and returns the indentation.
+  (indent-header #f read-only #t)
+
+  ;; Parser to scan over the body of the structure.  A procedure that
+  ;; accepts four arguments and returns two values.  The four
+  ;; arguments are: a parser description, a start mark, an end mark,
+  ;; and a parser stack.  The two values are: a mark and a parser
+  ;; stack.
+  (parse-body #f read-only #t)
+
+  ;; Procedure that computes the indentation for the body of the
+  ;; structure.  The procedure accepts one argument, a mark pointing
+  ;; to the beginning of the header, and returns the indentation.
+  (indent-body #f read-only #t)
+
+  ;; This value, if true for an ending fragment, causes the ender to
+  ;; close this many enclosing structures in addition to the innermost
+  ;; structure.
+  (pop-container 0 read-only #t))
+
+(define-variable keyparser-description
+  "Top-level description of buffer's syntax, for use by keyword parser."
+  #f)
+
+(define-command keyparser-indent-line
+  "Indent current line using the keyword syntax for this buffer."
+  "d"
+  (lambda (#!optional mark)
+    (let* ((mark (if (default-object? mark) (current-point) mark))
+	   (point? (mark= (line-start mark 0) (line-start (current-point) 0))))
+      (indent-line mark (keyparser-compute-indentation mark))
+      (if point?
+	  (let ((point (current-point)))
+	    (if (within-indentation? point)
+		(set-current-point! (indentation-end point))))))))
+
+(define-command keyparser-indent-region
+  "Indent current region using the keyword syntax for this buffer."
+  "r"
+  (lambda (region)
+    (let ((start
+	   (mark-left-inserting-copy (line-start (region-start region) 0)))
+	  (end (mark-left-inserting-copy (line-start (region-end region) 0))))
+      (let ((dstart (or (this-definition-start start) (group-start start))))
+	(let loop ((state (keyparse-initial dstart start)))
+	  ;; The temporary marks in STATE are to the left of START, and
+	  ;; thus are unaffected by insertion at START.
+	  (if (not (line-blank? start))
+	      (indent-line start
+			   (keyparser-compute-indentation-1 dstart
+							    start
+							    state)))
+	  (let ((start* (line-start start 1 'LIMIT)))
+	    (if (mark<= start* end)
+		(let ((state (keyparse-partial start start* state)))
+		  (move-mark-to! start start*)
+		  (loop state))))))
+      (mark-temporary! start)
+      (mark-temporary! end))))
+
+(define (indent-line mark indentation)
+  (let ((indent-point (indentation-end mark)))
+    (if (not (= indentation (mark-column indent-point)))
+	(change-indentation indentation indent-point))))
+
+(define (keyparser-compute-indentation mark)
+  (let ((dstart (or (this-definition-start mark) (group-start mark)))
+	(end (line-start mark 0)))
+    (keyparser-compute-indentation-1 dstart
+				     end
+				     (keyparse-initial dstart end))))
+
+(define (keyparser-compute-indentation-1 dstart lstart state)
+  ;; DSTART is the start of a top-level definition.  LSTART is the
+  ;; start of a line within that definition.  STATE is the keyparser
+  ;; state obtained by parsing from DSTART to LSTART.
+  (let ((char-state (keyparser-state/char-state state))
+	(description (ref-variable keyparser-description dstart)))
+    (if (and char-state (in-char-syntax-structure? char-state))
+	(cond ((parse-state-in-comment? char-state)
+	       ((description/indent-continued-comment description)
+		(parse-state-comment-start char-state)))
+	      ((> (parse-state-depth char-state) 0)
+	       (+ (mark-column
+		   (or (parse-state-containing-sexp char-state)
+		       (parse-state-containing-sexp
+			(parse-partial-sexp dstart lstart))))
+		  1))
+	      (else 0))
+	(let ((restart-point (keyparser-state/restart-point state))
+	      (stack (keyparser-state/stack state)))
+	  (if restart-point
+	      ((if (eq? 'HEADER (keyparser-state/restart-type state))
+		   (fragment/indent-header (stack-entry/fragment (car stack)))
+		   (description/indent-continued-statement description))
+	       restart-point)
+	      (if (null? stack)
+		  0
+		  (let ((entry (at-current-level? description lstart stack)))
+		    (if entry
+			(mark-indentation
+			 (stack-entry/start
+			  (car (if (stack-entry/end? entry)
+				   (pop-containers
+				    stack
+				    (stack-entry/fragment entry))
+				   stack))))
+			(let ((entry (car stack)))
+			  ((fragment/indent-body (stack-entry/fragment entry))
+			   (stack-entry/start entry)))))))))))
+
+(define-variable keyword-table
+  "String table of keywords, to control keyword-completion.
+See \\[complete-keyword]."
+  #f)
+
+(define-command complete-keyword
+  "Perform completion on keyword preceding point."
+  ()
+  (lambda ()
+    (let ((end 
+	   (let ((point (current-point)))
+	     (let ((end (group-end point)))
+	       (or (re-match-forward "\\sw+" point end #f)
+		   (and (mark< (group-start point) point)
+			(re-match-forward "\\sw+" (mark-1+ point) end #f))
+		   (editor-error "No keyword preceding point"))))))
+      (let ((start (backward-word end 1 'LIMIT)))
+	(standard-completion (extract-string start end)
+	  (lambda (prefix if-unique if-not-unique if-not-found)
+	    (string-table-complete (ref-variable keyword-table)
+				   prefix
+				   if-unique
+				   if-not-unique
+				   if-not-found))
+	  (lambda (completion)
+	    (delete-string start end)
+	    (insert-string completion start)))))))
+
+(define-structure (keyparser-state (conc-name keyparser-state/))
+  ;; CHAR-STATE is the result from the character parser.
+  (char-state #f read-only #t)
+
+  ;; STACK is a list of elements that indicate the keyword-structure
+  ;; nesting.  The first element of STACK indicates the innermost
+  ;; structure, subsequent elements indicate less-inner structures.
+  (stack #f read-only #t)
+
+  ;; RESTART-POINT is either #F or a mark.  This is used when the
+  ;; parser indicates that we are inside some simple structure, such
+  ;; as a list or a statement.  In that case, RESTART-POINT remembers
+  ;; where we were before we got into that structure, so we can resume
+  ;; the parser from that point once we get out of the structure.
+  (restart-point #f read-only #t)
+
+  ;; RESTART-TYPE is a symbol indicating what kind of structure
+  ;; RESTART-POINT is at the beginning of.  It can be 'HEADER,
+  ;; 'LEADER, or 'STATEMENT.
+  (restart-type #f read-only #t))
+
+;; Each stack entry consists of a PATTERN describing the structure
+;; that we're nested inside, an INDEX indicating which part of PATTERN
+;; we're in, and a START mark pointing to the beginning of the
+;; structure.
+
+(define-structure (stack-entry
+		   (conc-name stack-entry/)
+		   (print-procedure
+		    (standard-unparser-method 'STACK-ENTRY
+		      (lambda (entry port)
+			(write-char #\space port)
+			(write (fragment/keyword
+				(pattern/start
+				 (stack-entry/pattern entry)))
+			       port)))))
+  (pattern #f read-only #t)
+  (index #f read-only #t)
+  (start #f read-only #t))
+
+(define-integrable (stack-entry/end? entry)
+  (= 1 (stack-entry/index entry)))
+
+(define (stack-entry/fragment entry)
+  (list-ref (stack-entry/pattern entry)
+	    (stack-entry/index entry)))
+
+(define (keyparse-initial dstart mark)
+  (let ((lstart (line-start mark 0))
+	(state (make-keyparser-state #f '() #f #f)))
+    (if (mark= dstart lstart)
+	state
+	(keyparse-partial dstart lstart state))))
+
+(define (keyparse-partial start end state)
+  ;; STATE is the keyparser state corresponding to START; the value of
+  ;; this procedure is the keyparser state corresponding to END.
+  (let ((cs
+	 (parse-partial-sexp start end #f #f
+			     (keyparser-state/char-state state))))
+    (if (in-char-syntax-structure? cs)
+	(make-keyparser-state cs
+			      (keyparser-state/stack state)
+			      (or (keyparser-state/restart-point state) start)
+			      (keyparser-state/restart-type state))
+	(call-with-values
+	    (lambda ()
+	      (keyparse-forward (ref-variable keyparser-description start)
+				(or (keyparser-state/restart-point state)
+				    start)
+				end
+				(keyparser-state/stack state)))
+	  (lambda (stack restart-point restart-type)
+	    (make-keyparser-state cs stack restart-point restart-type))))))
+
+(define (keyparse-forward description start end stack)
+  (call-with-values
+      (lambda ()
+	(parse-forward-to-statement description start end))
+    (lambda (sstart kstart)
+      (cond ((not kstart)
+	     (values stack sstart 'LEADER))
+	    ((mark= kstart end)
+	     (if (mark= sstart kstart)
+		 (values stack #f #f)
+		 (values stack sstart 'STATEMENT)))
+	    (else
+	     (call-with-values
+		 (lambda ()
+		   (if (and (not (null? stack))
+			    (not (stack-entry/end? (car stack))))
+		       (match-current-level (stack-entry/pattern (car stack))
+					    kstart)
+		       (values #f #f)))
+	       (lambda (match index)
+		 (if match
+		     (continue-after-match
+		      description sstart match end
+		      (cons (make-stack-entry (stack-entry/pattern (car stack))
+					      index
+					      (stack-entry/start (car stack)))
+			    (cdr stack)))
+		     (call-with-values
+			 (lambda ()
+			   (match-structure-start description kstart))
+		       (lambda (match pattern)
+			 (if match
+			     (continue-after-match
+			      description sstart match end
+			      (cons (make-stack-entry pattern 0 sstart)
+				    stack))
+			     (let ((se
+				    ((description/find-statement-end
+				      description)
+				     kstart end)))
+			       (if se
+				   (continue-after-statement-end description
+								 se
+								 end
+								 stack)
+				   (values stack
+					   sstart
+					   'STATEMENT))))))))))))))
+
+(define (at-current-level? description lstart stack)
+  (call-with-values
+      (lambda ()
+	(parse-forward-to-statement description lstart (line-end lstart 0)))
+    (lambda (sstart kstart)
+      sstart
+      (and kstart
+	   (call-with-values
+	       (lambda ()
+		 (match-current-level (stack-entry/pattern (car stack))
+				      kstart))
+	     (lambda (match index)
+	       match
+	       (and match
+		    (make-stack-entry (stack-entry/pattern (car stack))
+				      index
+				      (stack-entry/start (car stack))))))))))
+
+(define (parse-forward-to-statement description start end)
+  (let ((sstart (skip-whitespace start end)))
+    (let outer ((mark sstart))
+      (if (mark= mark end)
+	  (values sstart mark)
+	  (let loop ((leaders (description/statement-leaders description)))
+	    (if (null? leaders)
+		(values sstart mark)
+		(let ((mark* (re-match-forward (caar leaders) mark)))
+		  (if mark*
+		      (let ((mark* ((cdar leaders) mark* end)))
+			(if mark*
+			    (outer (skip-whitespace mark* end))
+			    (values sstart #f)))
+		      (loop (cdr leaders))))))))))
+
+(define (skip-whitespace start end)
+  (backward-prefix-chars (forward-to-sexp-start start end) start))
+
+(define (continue-after-match description start match end stack)
+  (let ((fragment (stack-entry/fragment (car stack))))
+    (let ((mark
+	   (and (mark<= match end)
+		((fragment/parse-header fragment) match end))))
+      (cond ((not mark)
+	     (values stack start 'HEADER))
+	    ((stack-entry/end? (car stack))
+	     (continue-after-statement-end
+	      description mark end
+	      (pop-containers (cdr stack) fragment)))
+	    (else
+	     ((fragment/parse-body fragment) description mark end stack))))))
+
+(define (pop-containers stack fragment)
+  (let loop ((stack stack) (n (fragment/pop-container fragment)))
+    (if (and (pair? stack) (> n 0))
+	(loop (cdr stack) (- n 1))
+	stack)))
+
+(define (continue-after-statement-end description start end stack)
+  (keyparse-forward
+   description
+   start
+   end
+   (let loop ((stack stack))
+     (if (and (pair? stack)
+	      (not (pattern/end (stack-entry/pattern (car stack)))))
+	 (loop (cdr stack))
+	 stack))))
+
+(define (match-current-level pattern start)
+  (let loop ((fragments (cdr pattern)) (index 1))
+    (if (null? fragments)
+	(values #f #f)
+	(let ((mark
+	       (and (car fragments)
+		    (match-fragment (car fragments) start))))
+	  (if mark
+	      (values mark index)
+	      (loop (cdr fragments) (+ index 1)))))))
+
+(define (match-structure-start description start)
+  (let loop ((patterns (description/patterns description)))
+    (if (null? patterns)
+	(values #f #f)
+	(let* ((pattern (car patterns))
+	       (mark (match-fragment (pattern/start pattern) start)))
+	  (if mark
+	      (values mark pattern)
+	      (loop (cdr patterns)))))))
+
+(define (match-fragment fragment mark)
+  (let ((end (match-forward (fragment/keyword fragment) mark)))
+    (and end
+	 (or (line-end? end)
+	     (char=? #\space
+		     (char->syntax-code (ref-variable syntax-table end)
+					(mark-right-char end))))
+	 (let ((match-header (fragment/match-header fragment)))
+	   (if match-header
+	       (match-header end)
+	       end)))))
\ No newline at end of file
diff --git a/v7/src/edwin/vhdl.scm b/v7/src/edwin/vhdl.scm
new file mode 100644
index 000000000..9f3c26d91
--- /dev/null
+++ b/v7/src/edwin/vhdl.scm
@@ -0,0 +1,388 @@
+;;; -*-Scheme-*-
+;;;
+;;;	$Id: vhdl.scm,v 1.1 1997/03/07 23:31:22 cph Exp $
+;;;
+;;;	Copyright (c) 1997 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.
+;;;
+;;; NOTE: Parts of this program (Edwin) were created by translation
+;;; from corresponding parts of GNU Emacs.  Users should be aware that
+;;; the GNU GENERAL PUBLIC LICENSE may apply to these parts.  A copy
+;;; of that license should have been included along with this file.
+;;;
+
+;;;; Major Mode for VHDL Programs
+
+(declare (usual-integrations))
+
+(define-command vhdl-mode
+  "Enter VHDL mode."
+  ()
+  (lambda () (set-current-major-mode! (ref-mode-object vhdl))))
+
+(define-major-mode vhdl fundamental "VHDL"
+  "Major mode specialized for editing VHDL code."
+  (lambda (buffer)
+    (local-set-variable! syntax-table vhdl-mode:syntax-table buffer)
+    (local-set-variable! syntax-ignore-comments-backwards #f buffer)
+    (local-set-variable! comment-column 40 buffer)
+    (local-set-variable! comment-locator-hook vhdl-comment-locate buffer)
+    (local-set-variable! comment-indent-hook vhdl-comment-indentation buffer)
+    (local-set-variable! comment-start "-- " buffer)
+    (local-set-variable! comment-end "" buffer)
+    (let ((paragraph-start
+	   (string-append "^$\\|" (ref-variable page-delimiter buffer))))
+      (local-set-variable! paragraph-start paragraph-start buffer)
+      (local-set-variable! paragraph-separate paragraph-start buffer))
+    (local-set-variable! indent-line-procedure
+			 (ref-command keyparser-indent-line)
+			 buffer)
+    (local-set-variable! definition-start vhdl-defun-start-regexp buffer)
+    (local-set-variable! require-final-newline #t buffer)
+    (local-set-variable! keyparser-description
+			 vhdl-keyparser-description
+			 buffer)
+    (local-set-variable! keyword-table vhdl-keyword-table buffer)
+    (event-distributor/invoke! (ref-variable vhdl-mode-hook buffer)
+			       buffer)))
+
+(define vhdl-mode:syntax-table
+  (let ((syntax-table (make-syntax-table)))
+    (for-each (lambda (char) (modify-syntax-entry! syntax-table char "_"))
+	      (string->list "_.#+"))
+    (for-each (lambda (char) (modify-syntax-entry! syntax-table char "."))
+	      (string->list "*/&|<>=$%"))
+    (modify-syntax-entry! syntax-table #\\ "\"")
+    (modify-syntax-entry! syntax-table #\' "\"")
+    (modify-syntax-entry! syntax-table #\- "_ 56")
+    (modify-syntax-entry! syntax-table #\newline ">")
+    syntax-table))
+
+(define-key 'vhdl #\linefeed 'reindent-then-newline-and-indent)
+(define-key 'vhdl #\rubout 'backward-delete-char-untabify)
+(define-key 'vhdl #\tab 'keyparser-indent-line)
+(define-key 'vhdl #\c-m-\\ 'keyparser-indent-region)
+(define-key 'vhdl #\) 'lisp-insert-paren)
+(define-key 'vhdl #\] 'lisp-insert-paren)
+(define-key 'vhdl #\} 'lisp-insert-paren)
+(define-key 'vhdl #\m-tab 'complete-keyword)
+
+;;;; Syntax Description
+
+(define (vhdl-comment-locate mark)
+  (let ((state (parse-partial-sexp mark (line-end mark 0))))
+    (and (parse-state-in-comment? state)
+	 (vhdl-comment-match-start (parse-state-comment-start state))
+	 (cons (re-match-start 0) (re-match-end 0)))))
+
+(define (vhdl-comment-match-start mark)
+  (re-match-forward "--+[ \t]*" mark))
+
+(define (vhdl-comment-indentation mark)
+  (let ((column
+	 (cond ((match-forward "----" mark)
+		0)
+	       ((match-forward "---" mark)
+		(keyparser-compute-indentation mark))
+	       (else
+		(ref-variable comment-column mark)))))
+    (if (within-indentation? mark)
+	column
+	(max (+ (mark-column (horizontal-space-start mark)) 1)
+	     column))))
+
+(define vhdl-defun-start-regexp
+  (string-append
+   "^"
+   (regexp-group "architecture" "configuration" "entity"
+		 "library" "package" "use")
+   (regexp-group "\\s " "$")))
+
+(define vhdl-keyword-table
+  (alist->string-table
+   (map list
+	'("abs" "access" "after" "alias" "all" "and" "architecture" "array"
+	  "assert" "attribute" "begin" "block" "body" "buffer" "bus" "case"
+	  "component" "configuration" "constant" "disconnect" "downto" "else"
+	  "elsif" "end" "entity" "exit" "file" "for" "function" "generate"
+	  "generic" "group" "guarded" "if" "impure" "in" "inertial" "inout"
+	  "is" "label" "library" "linkage" "literal" "loop" "map" "mod" "nand"
+	  "new" "next" "nor" "not" "null" "of" "on" "open" "or" "others" "out"
+	  "package" "port" "postponed" "procedure" "process" "pure" "range"
+	  "record" "register" "reject" "rem" "report" "return" "rol" "ror"
+	  "select" "severity" "signal" "shared" "sla" "sll" "sra" "srl"
+	  "subtype" "then" "to" "transport" "type" "unaffected" "units" "until"
+	  "use" "variable" "wait" "when" "while" "with" "xnor" "xor"))
+   #f))
+
+(define (continued-header-indent mark)
+  (+ (mark-indentation mark)
+     (ref-variable vhdl-continued-header-offset mark)))
+
+(define (continued-statement-indent mark)
+  (+ (mark-indentation mark)
+     (ref-variable vhdl-continued-statement-offset mark)))
+
+(define comatch:identifier-start
+  (comatch:general
+   (lambda (start end)
+     (and (re-match-forward "\\s \\|^" start end)
+	  start))))
+
+(define comatch:identifier-end
+  (comatch:general
+   (lambda (start end)
+     (and (re-match-forward "\\s \\|$" start end)
+	  start))))
+
+(define comatch:skip-whitespace
+  (comatch:general
+   (lambda (start end)
+     (let loop ((start start))
+       (let ((start (skip-chars-forward " \t\f\n" start end)))
+	 (if (match-forward "--" start end)
+	     (let ((le (line-end start 0)))
+	       (and (mark<= le end)
+		    (loop le)))
+	     start))))))
+
+(define comatch:identifier
+  (comatch:append comatch:skip-whitespace
+		  (comatch:regexp "[a-zA-Z][a-zA-Z0-9_]*")
+		  comatch:identifier-end))
+
+(define (comatch:keyword keyword)
+  (comatch:append comatch:skip-whitespace
+		  (comatch:string keyword)
+		  comatch:identifier-end))
+
+(define comatch:list
+  (comatch:append comatch:skip-whitespace
+		  (comatch:and (comatch:char #\()
+			       comatch:sexp)))
+
+(define (match-for-loop mark)
+  (and (comatch-apply comatch:for-header:control mark)
+       mark))
+
+(define (match-for-component mark)
+  (and (comatch-apply comatch:for-header:component mark)
+       mark))
+
+(define (match-for-block mark)
+  (and (not (or (comatch-apply comatch:for-header:control mark)
+		(comatch-apply comatch:for-header:component mark)))
+       mark))
+
+(define comatch:for-header:control
+  (comatch:append comatch:identifier
+		  (comatch:keyword "in")))
+
+(define comatch:for-header:component
+  (comatch:append comatch:identifier
+		  (comatch:*
+		   (comatch:append comatch:skip-whitespace
+				   (comatch:char #\,)
+				   comatch:identifier))
+		  comatch:skip-whitespace
+		  (comatch:char #\:)))
+
+(define (match-if-then mark)
+  (and (eq? 'THEN (classify-if-header mark))
+       mark))
+
+(define (match-if-generate mark)
+  (and (eq? 'GENERATE (classify-if-header mark))
+       mark))
+
+(define (classify-if-header mark)
+  (let ((m (parse-forward-past-generate/then mark (group-end mark))))
+    (and m
+	 (let ((s (backward-one-sexp m)))
+	   (and s
+		(let ((e (forward-one-sexp s)))
+		  (and e
+		       (if (string-ci=? "then" (extract-string s e))
+			   'THEN
+			   'GENERATE))))))))
+
+(define ((parse-forward-past search) start end)
+  (let loop ((start start) (state #f))
+    (let ((mark (search start end)))
+      (and mark
+	   (let ((state (parse-partial-sexp start mark #f #f state)))
+	     (if (in-char-syntax-structure? state)
+		 (loop mark state)
+		 mark))))))
+
+(define (parse-forward-past-char char)
+  (parse-forward-past
+   (lambda (start end) (char-search-forward char start end #f))))
+
+(define parse-forward-past-semicolon
+  (parse-forward-past-char #\;))
+
+(define parse-forward-past-colon
+  (parse-forward-past-char #\:))
+
+(define (parse-forward-past-token token)
+  (parse-forward-past
+   (let ((regexp
+	  (string-append (regexp-group "\\s " "^")
+			 token
+			 (regexp-group "\\s " "$"))))
+     (lambda (start end)
+       (re-search-forward regexp start end)))))
+
+(define parse-forward-past-is
+  (parse-forward-past-token "is"))
+
+(define parse-forward-past-=>
+  (parse-forward-past-token "=>"))
+
+(define parse-forward-past-then
+  (parse-forward-past-token "then"))
+
+(define parse-forward-past-units
+  (parse-forward-past-token "units"))
+
+(define parse-forward-past-loop
+  (parse-forward-past-token "loop"))
+
+(define parse-forward-past-generate/loop
+  (parse-forward-past-token (regexp-group "generate" "loop")))
+
+(define parse-forward-past-generate/then
+  (parse-forward-past-token (regexp-group "generate" "then")))
+
+(define (parse-forward-noop start end)
+  end
+  start)
+
+(define (parse-process-header start end)
+  (comatch-apply comatch:process-header start end))
+
+(define comatch:process-header
+  (comatch:append (comatch:? comatch:list)
+		  (comatch:? (comatch:keyword "is"))))
+
+(define (parse-postponed-header start end)
+  (comatch-apply comatch:postponed-header start end))
+
+(define comatch:postponed-header
+  (comatch:append (comatch:keyword "process")
+		  comatch:process-header))
+
+(define (parse-component-header start end)
+  (comatch-apply comatch:component-header start end))
+
+(define comatch:component-header
+  (comatch:append comatch:identifier
+		  (comatch:? (comatch:keyword "is"))))
+
+(define vhdl-keyparser-description
+  (make-keyparser-description
+   'PATTERNS
+   (let ((standard-keyword
+	  (lambda (keyword match-header parse-header . rest)
+	    (apply make-keyparser-fragment
+		   'KEYWORD
+		   keyword
+		   'MATCH-HEADER
+		   match-header
+		   'PARSE-HEADER
+		   parse-header
+		   'INDENT-HEADER
+		   continued-header-indent
+		   'PARSE-BODY
+		   keyparse-forward
+		   'INDENT-BODY
+		   continued-statement-indent
+		   rest))))
+     (let ((begin-frag (standard-keyword "begin" #f parse-forward-noop))
+	   (end-frag (standard-keyword "end" #f parse-forward-past-semicolon)))
+       (append
+	(map (lambda (entry)
+	       (cons* (standard-keyword (car entry) (cadr entry) (caddr entry))
+		      end-frag
+		      (cdddr entry)))
+	     `(("architecture" #f ,parse-forward-past-is ,begin-frag)
+	       ("block" #f ,parse-process-header ,begin-frag)
+	       ("case" #f ,parse-forward-past-is)
+	       ("component" #f ,parse-component-header ,begin-frag)
+	       ("configuration" #f ,parse-forward-past-is)
+	       ("entity" #f ,parse-forward-past-is ,begin-frag)
+	       ("for" ,match-for-block ,parse-forward-noop)
+	       ("for" ,match-for-component ,parse-forward-past-colon)
+	       ("for" ,match-for-loop ,parse-forward-past-generate/loop)
+	       ("function" #f ,parse-forward-past-is ,begin-frag)
+	       ("pure" #f ,parse-forward-past-is ,begin-frag)
+	       ("impure" #f ,parse-forward-past-is ,begin-frag)
+	       ("if" ,match-if-then
+		     ,parse-forward-past-then
+		     ,(standard-keyword "elsif" #f parse-forward-past-then)
+		     ,(standard-keyword "else" #f parse-forward-noop))
+	       ("if" ,match-if-generate ,parse-forward-past-generate/then)
+	       ("package" #f ,parse-forward-past-is)
+	       ("procedure" #f ,parse-forward-past-is ,begin-frag)
+	       ("process" #f ,parse-process-header ,begin-frag)
+	       ("postponed" #f ,parse-postponed-header ,begin-frag)
+	       ("range" #f ,parse-forward-past-units)
+	       ("record" #f ,parse-forward-noop)
+	       ("while" #f ,parse-forward-past-loop)))
+	(list
+	 (let ((when (standard-keyword "when" #f parse-forward-past-=>)))
+	   (list when
+		 (standard-keyword "end" #f parse-forward-past-semicolon
+				   'POP-CONTAINER 1)
+		 when))))))
+	
+
+   'STATEMENT-LEADERS
+   `((,(re-compile-pattern "[a-zA-Z0-9_]+\\s *:" #f) . ,parse-forward-noop))
+   
+   'FIND-STATEMENT-END
+   parse-forward-past-semicolon
+
+   'INDENT-CONTINUED-STATEMENT
+   continued-statement-indent
+   
+   'INDENT-CONTINUED-COMMENT
+   (lambda (mark)
+     (mark-column (or (vhdl-comment-match-start mark) mark)))))
+
+;;; Edwin Variables:
+;;; scheme-environment: '(edwin)
+;;; scheme-syntax-table: edwin-syntax-table
+;;; End: