From 98f2ad221e7fb504c698b8ab7a6e74e6d5cd3d00 Mon Sep 17 00:00:00 2001
From: Joe Marshall <jmarshall@alum.mit.edu>
Date: Sun, 28 Mar 2010 12:39:08 -0700
Subject: [PATCH] Support for parsing the file attributes line.

---
 src/runtime/file-attributes.scm | 306 ++++++++++++++++++++++++++++++--
 src/runtime/make.scm            |   1 +
 src/runtime/parse.scm           | 210 ++++++++++++++++------
 3 files changed, 445 insertions(+), 72 deletions(-)

diff --git a/src/runtime/file-attributes.scm b/src/runtime/file-attributes.scm
index 3f4384c86..6316e0a24 100644
--- a/src/runtime/file-attributes.scm
+++ b/src/runtime/file-attributes.scm
@@ -28,22 +28,17 @@ USA.
 
 (declare (usual-integrations))
 
-;;; This file will parse "file attributes line" found in the first
+;;; This code will parse "file attributes line" found in the first
 ;;; or second line of file and delimited by the special -*- sequence.
-;;;
-;;; It currently contains just a stub function that the parser will
-;;; call when the delimiter is recognized within a comment.
-
-(define (parse-file-attributes-line port db multiline)
-  (declare (ignore port db multiline))
-  unspecific)
-
-(define (initialize-package!)
-  unspecific)
 
 ;;; Here are sample attribute lines taken from various files
 ;;; found in the wild.  They won't be parsed because they are not
 ;;; in the first two lines.
+
+;;; ---------------
+#| -*-Scheme-*-
+This file is part of MIT/GNU Scheme.
+|#
 
 #||-*- mode:lisp;
        package:(FOOBAR :USE (GLOBAL BAZ)
@@ -51,11 +46,9 @@ USA.
        base:10
    -*- ||#
 
-;;; -*- Mode: Java; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 2 -*- */
-
-;;; -*- Mode: C; tab-width: 4; -*- */
+;;; -*- Mode: Java; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 2 -*-
 
-;;; -*-mode:C;tab-width:3-*-
+;;; -*- Mode: C; tab-width: 4; -*-
 
 ;;; For Emacs: -*- mode:cperl; mode:folding -*-
 
@@ -63,7 +56,7 @@ USA.
 
 ;;; -*-mode:C;tab-width:3-*-
 
-;;; -*-mode:c; c-style:k&r; c-basic-offset:4; -*- */
+;;; -*-mode:c; c-style:k&r; c-basic-offset:4; -*-
 
 ;;;-*-Mode:LISP;Syntax: Common-Lisp;Package:ib;Base:10-*-
 
@@ -89,3 +82,284 @@ USA.
 
 ;;; It should surprise no one that the following comes from a python file.
 ;;; -*-*- encoding: utf-8 -*-*-
+
+;;; ---------------
+
+;;; The most general case is a series of key/value pairs where the key
+;;; is followed by a colon and the pairs are separated or delimited by
+;;; semicolons.  Whitespace is optional and cannot be relied upon to
+;;; delimit the end of a key or a value.
+
+;;; If the parser used the standard atom delimiters and the system
+;;; global parser table, a file attributes line like
+;;; "-*-mode:lisp;parser:read-*-" would be interpreted as the symbol
+;;; '-*-mode:lisp followed by a comment.  We therefore need to run the
+;;; parser with modified settings.
+
+;;; We need two modes.  The first is the mode where we are expecting
+;;; the key of a key/value pair.  Since the key is delimited by a
+;;; colon, or by whitespace followed by a colon, we need the colon
+;;; character to be atom-delimiter.
+
+;;; The second mode is when we are reading the value of a key/value
+;;; pair.  The value is read as an ordinary lisp object.  This is
+;;; slightly different from the standard settings of the Scheme
+;;; reader.
+
+;;; The actual way we parse the mode line is to stay in the first mode
+;;; until we read a colon character.  At that point, we switch to the
+;;; second mode in order to read a single value and return to the
+;;; first mode immediately afterwards.
+
+;; These are the char-sets and parser table for use in the mode where
+;; we are parsing anything but a value.  (mode 1)
+(define char-set/file-attributes-atom-delimiters)
+(define char-set/file-attributes-constituents)
+(define file-attributes-parser-table)
+
+(define (parse-file-attributes-item parse port)
+  ;; Prepare the parser for first mode.
+  (fluid-let ((*parser-associate-positions?* #f)
+	      (*parser-atom-delimiters*
+	       char-set/file-attributes-atom-delimiters)
+	      (*parser-canonicalize-symbols?* #f)
+	      (*parser-constituents* char-set/file-attributes-constituents)
+	      (*parser-enable-file-attributes-parsing?* #f) ; no recursion!
+	      (*parser-keyword-style* #f)
+	      (*parser-radix* 10)
+	      (*parser-table* file-attributes-parser-table))
+    (parse port system-global-environment)))
+
+(define (parse-file-attributes-value parse port)
+  ;; Prepare the parser for second mode.
+  (fluid-let ((*parser-associate-positions?* #f)
+	      (*parser-atom-delimiters* char-set/atom-delimiters)
+	      (*parser-canonicalize-symbols?* #f)
+	      (*parser-constituents* char-set/constituents)
+	      (*parser-enable-file-attributes-parsing?* #f) ; no recursion!
+	      ;; enable prefix keywords
+	      (*parser-keyword-style* 'prefix)
+	      (*parser-radix* 10)
+	      (*parser-table* system-global-parser-table))
+    (parse port system-global-environment)))
+
+(define (parse-file-attributes-line port db multiline)
+  (declare (ignore db))
+  (tokens->alist
+   (tokenize-file-attributes-line port multiline)))
+
+;; If we don't see a COLON or a SEMICOLON often enough, we'll assume
+;; that we're confused by an ill-formed attributes line and abandon
+;; the parsing.
+(define file-attributes-confusion-limit 3)
+
+(define (tokenize-file-attributes-line port multiline)
+  (let ((parser (top-level-parser port)))
+
+    (define (tokenize confusion-count tokens)
+      (if (> confusion-count file-attributes-confusion-limit)
+	  (begin
+	    (warn "Ill-formed file attributes list.")
+	    #f)
+
+	  (let ((token (if (and (pair? tokens)
+				(eq? (car tokens) colon-token))
+			   (parse-file-attributes-value parser port)
+			   (parse-file-attributes-item parser port))))
+
+	    (cond ((eof-object? token) (if multiline
+					   (error:premature-eof port)
+					   token))
+
+		  ((or (eq? token colon-token)
+		       (eq? token semicolon-token))
+		   ;; saw a colon or semicolon, we're still on track.
+		   (tokenize 0 (cons token tokens)))
+
+		  ((eq? token newline-token)
+		   (if multiline
+		       ;; discard if multiline
+		       (tokenize (+ confusion-count 1) tokens)
+		       ;; If we hit the end of line while parsing a single
+		       ;; line, then the file attributes line is ill-formed.
+		       (begin
+			 (warn "Ill-formed file attributes line.")
+			 #f)))
+
+		  ((symbol? token)
+		   (let ((token* (if (null? tokens)
+				     (trim-initial-token token)
+				     token)))
+		     (cond ((not token*) (tokenize confusion-count tokens))
+			   ((string-suffix? "-*-" (symbol-name token*))
+			    (let ((token** (trim-final-token token*)))
+			      (if token**
+				  (reverse (cons token** tokens))
+				  (reverse tokens))))
+			   (else (tokenize (+ confusion-count 1)
+					   (cons token* tokens))))))
+
+		  (else (tokenize (+ confusion-count 1)
+				  (cons token tokens)))))))
+
+    (tokenize 0 '())))
+
+;;; In the case where the file attributes line has spurious *-
+;;; characters, and perhaps is not whitespace delimited, these
+;;; characters will end up being the first token or prepended to the
+;;; first token.  Examples:
+;;;  -*-*- encoding: utf-8 -*-*-
+;;;  -*-*-*-logrus-*-*-*-
+;;;  -*-*- coding: latin-1 -*-*-
+
+(define (trim-initial-token sym)
+  (if (string-prefix? "*-" (symbol-name sym))
+      (do ((token-string (symbol-name sym) (string-tail token-string 2)))
+	  ((not (string-prefix? "*-" token-string))
+	   (if (zero? (string-length token-string))
+	       #f
+	       (string->symbol token-string)))))
+  sym)
+
+;;; If the final token is a symbol that is not whitespace delimited,
+;;; then the end marker will be attached to the token.  Furthermore,
+;;; if there are spurious -* characters, these will have been attached
+;;; as well.  Examples:
+;;; -*-Scheme-*-
+;;; -*-outline-*-*-
+(define (trim-final-token sym)
+  (do ((token-string
+	(let ((s (symbol-name sym)))
+	  (string-head s (- (string-length s) 3)))
+	(string-head token-string (- (string-length token-string) 2))))
+      ((not (string-suffix? "-*" token-string))
+       (if (zero? (string-length token-string))
+	   #f
+	   (string->symbol token-string)))))
+
+;;; Given a list of tokens, create an alist of keys and values.
+(define (tokens->alist tokens)
+
+  ;; A single token is a mode indicator
+  (define (parse-mode mode-token)
+    (list (cons 'MODE mode-token)))
+
+  ;; An attribute consists of a key, colon, value
+  ;; triplet.  The key must be a symbol.
+  (define (parse-attribute tokens)
+    (let ((key (car tokens))
+	  (t1 (cdr tokens)))
+      (if (or (not (symbol? key))
+	      (not (pair? t1)))
+	  (ill-formed)
+	  (let ((colon (car t1))
+		(t2 (cdr t1)))
+	    (if (or (not (eq? colon colon-token))
+		    (not (pair? t2)))
+		(ill-formed)
+		(let ((value (car t2))
+		      (t3 (cdr t2)))
+		  (if (not (null? t3))
+		      (ill-formed)
+		      (cons key value))))))))
+
+  (define (parse-attributes-alist tokens)
+    (define (group alist accum tail)
+      (if (pair? tail)
+	  (let ((token (car tail)))
+	    (if (eq? token semicolon-token)
+		(let ((entry (parse-attribute (reverse accum))))
+		  (group (if entry
+			     (cons entry alist)
+			     alist)
+			 '()
+			 (cdr tail)))
+		(group alist (cons token accum) (cdr tail))))
+	  (if (null? accum)
+	      (reverse alist)
+	      (reverse (let ((entry (parse-attribute (reverse accum))))
+			 (if entry
+			     (cons entry alist)
+			     alist))))))
+    (group '() '() tokens))
+
+  (define (ill-formed)
+    (warn "Ill-formed file attributes list.")
+    #f)
+
+  (if (pair? tokens)
+      (cond ((memq semicolon-token tokens)
+	     (parse-attributes-alist tokens))
+
+	    ((memq colon-token tokens)
+	     (list (parse-attribute tokens)))
+
+	    ((null? (cdr tokens))
+	     (parse-mode (car tokens)))
+
+	    (else (list tokens)))
+      #f))
+
+(define (initialize-package!)
+  (let* ((constituents char-set/constituents)
+	 (atom-delimiters
+	  (char-set-union char-set:whitespace
+			  ;; Note that colon is a delimiter!
+			  (string->char-set "()[]{}\":;'`,")
+			  (char-set #\U+00AB #\U+00BB)))
+	 (symbol-leaders
+	  (char-set-difference constituents
+			       (char-set-union atom-delimiters
+					       char-set/number-leaders)))
+	 (special-number-leaders
+	  (string->char-set "bBoOdDxXiIeEsSlL"))
+	 (store-char (lambda (v c h) (vector-set! v (char->integer c) h)))
+	 (store-char-set
+	  (lambda (v c h)
+	    (for-each (lambda (c) (store-char v c h))
+		      (char-set-members c)))))
+    (let ((initial (make-vector #x100 #f))
+	  (special (make-vector #x100 #f)))
+      (store-char-set initial char-set:whitespace handler:whitespace)
+      (store-char initial #\newline handler:newline)
+      (store-char-set initial char-set/number-leaders handler:atom)
+      (store-char-set initial symbol-leaders handler:symbol)
+      (store-char-set special special-number-leaders handler:number)
+      (store-char initial #\( handler:list)
+      (store-char special #\( handler:vector)
+      (store-char initial #\) handler:close-parenthesis)
+      (store-char initial #\: handler:colon)
+      (store-char initial #\; handler:semicolon)
+      (store-char initial #\' handler:quote)
+      (store-char initial #\` handler:quasiquote)
+      (store-char initial #\, handler:unquote)
+      (store-char initial #\" handler:string)
+      (store-char initial #\# handler:special)
+      (store-char special #\f handler:false)
+      (store-char special #\F handler:false)
+      (store-char special #\t handler:true)
+      (store-char special #\T handler:true)
+      (store-char special #\\ handler:char)
+;    (store-char special #\! handler:named-constant)
+      (set! file-attributes-parser-table (make-parser-table initial special))
+      )
+    (set! char-set/file-attributes-atom-delimiters atom-delimiters)
+    (set! char-set/file-attributes-constituents constituents))
+  unspecific)
+
+(define (handler:newline port db ctx char)
+  (declare (ignore port db ctx char))
+  newline-token)
+
+(define (handler:colon port db ctx char)
+  (declare (ignore port db ctx char))
+  colon-token)
+
+(define (handler:semicolon port db ctx char)
+  (declare (ignore port db ctx char))
+  semicolon-token)
+
+(define colon-token (list 'COLON))
+(define newline-token (list 'NEWLINE))
+(define semicolon-token (list 'SEMICOLON))
+
diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index d3b62d822..302925d21 100644
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -500,6 +500,7 @@ USA.
    (RUNTIME KEYWORD)
    (RUNTIME NUMBER-PARSER)
    (RUNTIME PARSER)
+   (RUNTIME PARSER FILE-ATTRIBUTES)
    ((RUNTIME PATHNAME) INITIALIZE-PARSER-METHOD!)
    (RUNTIME UNPARSER)
    (RUNTIME UNSYNTAXER)
diff --git a/src/runtime/parse.scm b/src/runtime/parse.scm
index 8ab3e6d04..06a7554b8 100644
--- a/src/runtime/parse.scm
+++ b/src/runtime/parse.scm
@@ -67,16 +67,20 @@ USA.
 	    (read-finish (port/operation port 'READ-FINISH)))
 	(lambda (port environment)
 	  (if read-start (read-start port))
-	  (let ((db (initial-db port environment)))
-	    (let ((object (dispatch port db 'TOP-LEVEL)))
-	      (if read-finish (read-finish port))
-	      (finish-parsing object db)))))))
+	  (let restart ()
+	    (let* ((db (initial-db port environment))
+		   (object (dispatch port db 'TOP-LEVEL)))
+	      (if (eq? object restart-parsing)
+		  (restart)
+		  (begin
+		    (if read-finish (read-finish port))
+		    (finish-parsing object db)))))))))
 
 (define (read-in-context port db ctx)
   (let ((object (dispatch port db ctx)))
-    (if (eof-object? object)
-	(error:premature-eof port))
-    object))
+    (cond ((eof-object? object)	(error:premature-eof port))
+	  ((eq? object restart-parsing) (error:unexpected-restart port))
+	  (else object))))
 
 (define-integrable (read-object port db)
   (read-in-context port db 'OBJECT))
@@ -89,15 +93,24 @@ USA.
 	(if (eof-object? char)
 	    char
 	    (let ((object ((get-handler char handlers) port db ctx char)))
-	      (if (eq? object continue-parsing)
-		  (loop)
-		  (begin
-		    (record-object-position! position object db)
-		    object))))))))
-
+	      (cond ((eq? object continue-parsing) (loop))
+		    ((eq? object restart-parsing) object)
+		    (else
+		     (record-object-position! position object db)
+		     object))))))))
+
+;; Causes the dispatch to be re-run.
+;; Used to discard things like whitespace and comments.
 (define continue-parsing
   (list 'CONTINUE-PARSING))
 
+;; Causes the dispatch to finish, but the top-level parser will return
+;; back into the dispatch after re-initializing the db.  This is used
+;; to reset the parser when changing read syntax as specified by the
+;; file attributes list.
+(define restart-parsing
+  (list 'RESTART-PARSING))
+
 (define (handler:special port db ctx char1)
   (let ((char2 (%read-char/no-eof port db)))
     ((get-handler char2 (parser-table/special (db-parser-table db)))
@@ -221,25 +234,24 @@ USA.
 		   (case char
 		     ((#\newline) unspecific)
 		     ((#\-)
-		      (parse-file-attributes-line port db false)
-		      (discard))
+		      (process-file-attributes
+		       (parse-file-attributes-line port db false) port)
+		      (discard restart-parsing))
 		     (else (scan))))))
 	    ((#\-) (dash))
 	    (else (scan))))))
 
-  (define (discard)
+  (define (discard action)
     (let ((char (%read-char port db)))
       (cond ((eof-object? char) char)
-	    ((char=? char #\newline) unspecific)
-	    (else (discard)))))
+	    ((char=? char #\newline) action)
+	    (else (discard action)))))
 
   ;; If we're past the second line, just discard.
   (if (and (< (current-line port db) 2)
 	   (db-enable-file-attributes-parsing db))
       (scan)
-      (discard))
-
-  continue-parsing)
+      (discard continue-parsing)))
 
 (define (handler:multi-line-comment
 	 port db ctx char1 char2)
@@ -257,7 +269,7 @@ USA.
 
   (define (scan)
     (case (%read-char/no-eof port db)
-      ((#\newline) (discard 0))
+      ((#\newline) (discard 0 continue-parsing))
       ((#\#) (sharp))
       ((#\-) (dash))
       ((#\|) (vbar))
@@ -265,15 +277,15 @@ USA.
 
   (define (sharp)
     (case (%read-char/no-eof port db)
-      ((#\newline) (discard 0))
+      ((#\newline) (discard 0 continue-parsing))
       ((#\#) (sharp))
       ((#\-) (dash))
-      ((#\|) (discard 1))		; nested comment
+      ((#\|) (discard 1 continue-parsing))		; nested comment
       (else (scan))))
 
   (define (vbar)
     (case (%read-char/no-eof port db)
-      ((#\newline) (discard 0))
+      ((#\newline) (discard 0 continue-parsing))
       ((#\#) unspecific)		; end of comment
       ((#\-) (dash))
       ((#\|) (vbar))
@@ -281,7 +293,7 @@ USA.
 
   (define (dash)
     (case (%read-char/no-eof port db)
-      ((#\newline) (discard 0))
+      ((#\newline) (discard 0 continue-parsing))
       ((#\#) (sharp))
       ((#\*) (dash-star))
       ((#\-) (dash))
@@ -290,9 +302,11 @@ USA.
 
   (define (dash-star)
     (case (%read-char/no-eof port db)
-      ((#\newline) (discard 0))
+      ((#\newline) (discard 0 continue-parsing))
       ((#\#) (sharp))
-      ((#\-) (parse-file-attributes-line port db true) (discard 0))
+      ((#\-)
+       (process-file-attributes (parse-file-attributes-line port db true) port)
+       (discard 0 restart-parsing))
       ((#\|) (vbar))
       (else (scan))))
 
@@ -300,34 +314,33 @@ USA.
   ;; just track the nesting level and discard stuff.
   ;; We don't look for the file-attribute marker.
 
-  (define (discard depth)
+  (define (discard depth action)
     (case (%read-char/no-eof port db)
-      ((#\#) (discard-sharp depth))
-      ((#\|) (discard-vbar depth))
-      (else (discard depth))))
+      ((#\#) (discard-sharp depth action))
+      ((#\|) (discard-vbar depth action))
+      (else (discard depth action))))
 
-  (define (discard-sharp depth)
+  (define (discard-sharp depth action)
     (case (%read-char/no-eof port db)
-      ((#\#) (discard-sharp depth))
-      ((#\|) (discard (+ depth 1))) ; push
-      (else (discard depth))))
+      ((#\#) (discard-sharp depth action))
+      ((#\|) (discard (+ depth 1) action)) ; push
+      (else (discard depth action))))
 
-  (define (discard-vbar depth)
+  (define (discard-vbar depth action)
     (case (%read-char/no-eof port db)
       ((#\#) (if (> depth 0)
-		 (discard (- depth 1)) ; pop
-		 unspecific))
-      ((#\|) (discard-vbar depth))
-      (else (discard depth))))
+		 (discard (- depth 1) action) ; pop
+		 action))
+      ((#\|) (discard-vbar depth action))
+      (else (discard depth action))))
 
   ;; Start the machine.
   ;; If we're past the second line, just discard.
   (if (and (< (current-line port db) 2)
 	   (db-enable-file-attributes-parsing db))
       (scan)
-      (discard 0))
+      (discard 0 continue-parsing)))
 
-  continue-parsing)
 
 ;; It would be better if we could skip over the object without
 ;; creating it, but for now this will work.
@@ -745,7 +758,7 @@ USA.
     (if (eof-object? char)
 	(error:premature-eof port))
     char))
-
+
 (define-structure db
   (associate-positions? #f read-only #t)
   (atom-delimiters #f read-only #t)
@@ -780,11 +793,12 @@ USA.
     (guarantee-char-set constituents #f)
     (make-db (environment-lookup environment '*PARSER-ASSOCIATE-POSITIONS?*)
 	     atom-delimiters
-	     (environment-lookup environment '*PARSER-CANONICALIZE-SYMBOLS?*)
+	     (overridable-value
+	      port environment '*PARSER-CANONICALIZE-SYMBOLS?*)
 	     constituents
-	     (environment-lookup environment
-				 '*PARSER-ENABLE-FILE-ATTRIBUTES-PARSING?*)
-	     (environment-lookup environment '*PARSER-KEYWORD-STYLE*)
+	     (overridable-value
+	      port environment '*PARSER-ENABLE-FILE-ATTRIBUTES-PARSING?*)
+	     (overridable-value port environment '*PARSER-KEYWORD-STYLE*)
 	     (environment-lookup environment '*PARSER-RADIX*)
 	     (environment-lookup environment '*PARSER-TABLE*)
 	     (make-shared-objects)
@@ -795,6 +809,11 @@ USA.
 	     (port/operation port 'READ-CHAR)
 	     '())))
 
+(define (overridable-value port environment name)
+  ;; Check the port property list for the name, and then the
+  ;; environment.  This way a port can override the default.
+  (port/get-property port name (environment-lookup environment name)))
+
 (define (position-operation port environment)
   (let ((default (lambda (port) port #f)))
     (if (environment-lookup environment '*PARSER-ASSOCIATE-POSITIONS?*)
@@ -802,12 +821,12 @@ USA.
 	    default)
 	default)))
 
-(define-integrable (current-position port db)
-  ((db-get-position db) port))
-
 (define-integrable (current-line port db)
   ((db-input-line db) port))
 
+(define-integrable (current-position port db)
+  ((db-get-position db) port))
+
 (define-integrable (record-object-position! position object db)
   (if (and position (object-pointer? object))
       (set-db-position-mapping! db
@@ -819,6 +838,79 @@ USA.
       (cons object (db-position-mapping db))
       object))
 
+(define (process-file-attributes file-attribute-alist port)
+  (if file-attribute-alist
+      (begin
+	;; Disable further attributes parsing.
+	(port/set-property! port '*PARSER-ENABLE-FILE-ATTRIBUTES-PARSING?* #f)
+	(process-keyword-attribute file-attribute-alist port)
+	(process-mode-attribute file-attribute-alist port)
+	(process-studly-case-attribute file-attribute-alist port))))
+
+(define (lookup-file-attribute file-attribute-alist attribute)
+  (assoc attribute file-attribute-alist
+	 (lambda (left right)
+	   (string-ci=? (symbol-name left) (symbol-name right)))))
+
+;;; Look for keyword-style: prefix or keyword-style: suffix
+(define (process-keyword-attribute file-attribute-alist port)
+  (let ((keyword-entry
+	 (lookup-file-attribute file-attribute-alist 'KEYWORD-STYLE)))
+    (if (pair? keyword-entry)
+	(let ((value (cdr keyword-entry)))
+	  (cond ((and (symbol value)
+		      (string-ci=? (symbol-name value) "prefix"))
+		 (port/set-property! port '*PARSER-KEYWORD-STYLE* 'PREFIX))
+		((and (symbol value)
+		      (string-ci=? (symbol-name value) "suffix"))
+		 (port/set-property! port '*PARSER-KEYWORD-STYLE* 'SUFFIX))
+		(else
+		 (warn "Unrecognized value for keyword-style" value)))))))
+
+;;; Don't do anything with the mode, but warn if it isn't scheme.
+(define (process-mode-attribute file-attribute-alist port)
+  (declare (ignore port))
+  (let ((mode-entry
+	 (lookup-file-attribute file-attribute-alist 'KEYWORD-STYLE)))
+    (if (pair? mode-entry)
+	(let ((value (cdr mode-entry)))
+	  (if (or (not (symbol value))
+		  (not (string-ci=? (symbol-name value) "scheme")))
+	      (warn "Unexpected file mode:" (if (symbol? value)
+						(symbol-name value)
+						value)))))))
+
+;; If you want to turn on studly case, then the attribute must be
+;; exactly "sTuDly-case" and the value must be exactly "True".  After
+;; all, case is important.  If you want to turn it off, the case of
+;; the attribute and the value don't matter.
+(define (process-studly-case-attribute file-attribute-alist port)
+  (let ((studly-case-entry
+	 (lookup-file-attribute file-attribute-alist 'STUDLY-CASE)))
+    (if (pair? studly-case-entry)
+	(let ((value (cdr studly-case-entry)))
+	  (cond ((or (eq? value #t)
+		     (and (symbol? value)
+			  (string-ci=? (symbol-name value) "true")))
+		 ;; STricTly cHeck thE case.
+		 (cond ((not (string=? (symbol-name (car studly-case-entry))
+				       "sTuDly-case"))
+			(warn "Attribute name mismatch.  Expected sTuDly-case.")
+			#f)
+		       ((and (symbol? value)
+			     (not (string=? (symbol-name value) "True")))
+			(warn "Attribute value mismatch.  Expected True.")
+			#f)
+		       (else
+			(port/set-property!
+			 port '*PARSER-CANONICALIZE-SYMBOLS?* #f))))
+		((or (not value)
+		     (and (symbol? value)
+			  (string-ci=? (symbol-name value) "false")))
+		 (port/set-property! port '*PARSER-CANONICALIZE-SYMBOLS?* #t))
+		(else (warn "Unrecognized value for sTuDly-case" value)))))))
+
+
 (define-syntax define-parse-error
   (sc-macro-transformer
    (lambda (form environment)
@@ -844,7 +936,6 @@ USA.
 					   STANDARD-ERROR-HANDLER)))))
 	 (ill-formed-syntax form)))))
 
-(define condition-type:parse-error)
 (define condition-type:illegal-bit-string)
 (define condition-type:illegal-boolean)
 (define condition-type:illegal-char)
@@ -853,12 +944,14 @@ USA.
 (define condition-type:illegal-named-constant)
 (define condition-type:illegal-number)
 (define condition-type:illegal-unhash)
-(define condition-type:undefined-hash)
 (define condition-type:no-quoting-allowed)
+(define condition-type:non-shared-object)
+(define condition-type:parse-error)
 (define condition-type:premature-eof)
 (define condition-type:re-shared-object)
-(define condition-type:non-shared-object)
 (define condition-type:unbalanced-close)
+(define condition-type:undefined-hash)
+(define condition-type:unexpected-restart)
 (define error:illegal-bit-string)
 (define error:illegal-boolean)
 (define error:illegal-char)
@@ -867,12 +960,13 @@ USA.
 (define error:illegal-named-constant)
 (define error:illegal-number)
 (define error:illegal-unhash)
-(define error:undefined-hash)
 (define error:no-quoting-allowed)
+(define error:non-shared-object)
 (define error:premature-eof)
 (define error:re-shared-object)
-(define error:non-shared-object)
 (define error:unbalanced-close)
+(define error:undefined-hash)
+(define error:unexpected-restart)
 
 (define (initialize-condition-types!)
   (set! condition-type:parse-error
@@ -946,4 +1040,8 @@ USA.
     (lambda (char port)
       (write-string "Unbalanced close parenthesis: " port)
       (write char port)))
+  (define-parse-error (unexpected-restart port)
+    (lambda (port* port)
+      (write-string "Unexpected parse restart on: " port)
+      (write port* port)))
   unspecific)
\ No newline at end of file
-- 
2.25.1