From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 13 Nov 1992 22:43:45 +0000 (+0000)
Subject: Add M-x describe-syntax.
X-Git-Tag: 20090517-FFI~8774
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b8f94a7ca678dd2f1e0ae6c2b04dd235978d81cd;p=mit-scheme.git

Add M-x describe-syntax.
---

diff --git a/v7/src/edwin/modefs.scm b/v7/src/edwin/modefs.scm
index ab7c7d3c4..a02bff879 100644
--- a/v7/src/edwin/modefs.scm
+++ b/v7/src/edwin/modefs.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: modefs.scm,v 1.141 1992/10/20 20:03:14 jinx Exp $
+;;;	$Id: modefs.scm,v 1.142 1992/11/13 22:43:45 cph Exp $
 ;;;
 ;;;	Copyright (c) 1985, 1989-92 Massachusetts Institute of Technology
 ;;;
@@ -238,6 +238,7 @@ Like Fundamental mode, but no self-inserting characters.")
 (define-key 'fundamental '(#\c-h #\k) 'describe-key)
 (define-key 'fundamental '(#\c-h #\l) 'view-lossage)
 (define-key 'fundamental '(#\c-h #\m) 'describe-mode)
+(define-key 'fundamental '(#\c-h #\s) 'describe-syntax)
 (define-key 'fundamental '(#\c-h #\t) 'help-with-tutorial)
 (define-key 'fundamental '(#\c-h #\v) 'describe-variable)
 (define-key 'fundamental '(#\c-h #\w) 'where-is)
@@ -299,7 +300,7 @@ Like Fundamental mode, but no self-inserting characters.")
 (define-key 'fundamental '(#\c-x #\q) 'kbd-macro-query)
 (define-key 'fundamental '(#\c-x #\r) 'copy-rectangle-to-register)
 (define-key 'fundamental '(#\c-x #\s) 'save-some-buffers)
-;(define-key 'fundamental '(#\c-x #\t) 'transpose-regions)
+;;(define-key 'fundamental '(#\c-x #\t) 'transpose-regions)
 (define-key 'fundamental '(#\c-x #\u) 'undo)
 (define-key 'fundamental '(#\c-x #\w) 'widen)
 (define-key 'fundamental '(#\c-x #\x) 'copy-to-register)
diff --git a/v7/src/edwin/syntax.scm b/v7/src/edwin/syntax.scm
index 5bd12318d..a12cbdfa8 100644
--- a/v7/src/edwin/syntax.scm
+++ b/v7/src/edwin/syntax.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/syntax.scm,v 1.75 1992/07/09 15:55:19 arthur Exp $
+;;;	$Id: syntax.scm,v 1.76 1992/11/13 22:43:33 cph Exp $
 ;;;
-;;;	Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
+;;;	Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
 ;;;
 ;;;	This material was developed by the Scheme project at the
 ;;;	Massachusetts Institute of Technology, Department of
@@ -104,6 +104,23 @@
   ((ucode-primitive char->syntax-code) (syntax-table/entries syntax-table)
 				       char))
 
+(define (syntax-entry->string entry)
+  (let ((code (fix:and #xff entry)))
+    (if (> code 12)
+	"invalid"
+	(string-append
+	 (vector-ref '#(" " "." "w" "_" "(" ")" "'" "\"" "$" "\\" "/" "<" ">")
+		     code)
+	 (let ((match (fix:and #xff (fix:lsh -8 entry))))
+	   (if (zero? match)
+	       " "
+	       (emacs-key-name (ascii->char match) false)))
+	 (if (fix:= 0 (fix:and #x10000 entry)) "" "1")
+	 (if (fix:= 0 (fix:and #x20000 entry)) "" "2")
+	 (if (fix:= 0 (fix:and #x40000 entry)) "" "3")
+	 (if (fix:= 0 (fix:and #x80000 entry)) "" "4")
+	 (if (fix:= 0 (fix:and #x100000 entry)) "" "p")))))
+
 (define (substring-find-next-char-of-syntax string start end
 					    syntax-table syntax)
   (let loop ((index start))
@@ -124,6 +141,79 @@
 	     (loop (+ index 1))
 	     index))))
 
+(define-command describe-syntax
+  "Describe the syntax specifications in the syntax table.
+The descriptions are inserted in a buffer,
+which is selected so you can see it."
+  ()
+  (lambda ()
+    (with-output-to-help-display
+     (lambda ()
+       (newline)
+       (let ((table (syntax-table/entries (ref-variable syntax-table))))
+	 (let ((table-end (vector-length table))
+	       (describe-char-range
+		(lambda (bottom top)
+		  (let ((describe-char
+			 (lambda (ascii)
+			   (emacs-key-name (ascii->char ascii) false)))
+			(top (- top 1)))
+		    (if (= bottom top)
+			(describe-char bottom)
+			(string-append (describe-char bottom)
+				       " .. "
+				       (describe-char top)))))))
+	   (let loop ((start 0))
+	     (if (< start table-end)
+		 (let* ((entry (vector-ref table start))
+			(end
+			 (let loop ((index (+ start 1)))
+			   (if (and (< index table-end)
+				    (eqv? entry (vector-ref table index)))
+			       (loop (+ index 1))
+			       index))))
+		   (let ((range-desc (describe-char-range start end)))
+		     (write-string range-desc)
+		     (write-char #\tab)
+		     (if (< (string-length range-desc) 8)
+			 (write-char #\tab)))
+		   (describe-syntax-entry entry)
+		   (loop end))))))))))
+
+(define (describe-syntax-entry entry)
+  (let ((code (fix:and #xff entry)))
+    (if (> code 12)
+	(write-string "invalid")
+	(begin
+	  (write-string (syntax-entry->string entry))
+	  (write-string "\twhich means: ")
+	  (write-string
+	   (vector-ref '#("whitespace" "punctuation" "word" "symbol" "open"
+				       "close" "quote" "string" "math"
+				       "escape" "charquote" "comment"
+				       "endcomment" "invalid")
+		       code))
+	  (let ((match (fix:and #xff (fix:lsh -8 entry))))
+	    (if (not (zero? match))
+		(begin
+		  (write-string ", matches ")
+		  (write-string (emacs-key-name (ascii->char match) false)))))
+	  (if (not (fix:= 0 (fix:and #x10000 entry)))
+	      (write-string
+	       ",\n\t  is the first character of a comment-start sequence"))
+	  (if (not (fix:= 0 (fix:and #x20000 entry)))
+	      (write-string
+	       ",\n\t  is the second character of a comment-start sequence"))
+	  (if (not (fix:= 0 (fix:and #x40000 entry)))
+	      (write-string
+	       ",\n\t  is the first character of a comment-end sequence"))
+	  (if (not (fix:= 0 (fix:and #x80000 entry)))
+	      (write-string
+	       ",\n\t  is the second character of a comment-end sequence"))
+	  (if (not (fix:= 0 (fix:and #x100000 entry)))
+	      (write-string ",\n\t  is a prefix character")))))
+  (newline))
+
 ;;;; Word Parsing
 
 (define-variable syntax-table