From: Chris Hanson Date: Wed, 8 Mar 2017 05:37:27 +0000 (-0800) Subject: Reimplement interface between parser and file-attributes parser. X-Git-Tag: mit-scheme-pucked-9.2.12~158^2~107 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c4e853decc76f31ec6e78739878bb34fd74f7d63;p=mit-scheme.git Reimplement interface between parser and file-attributes parser. New interface just collects the comment and passes it to the parser. --- diff --git a/src/runtime/file-attributes.scm b/src/runtime/file-attributes.scm index 8b422e409..dadf87902 100644 --- a/src/runtime/file-attributes.scm +++ b/src/runtime/file-attributes.scm @@ -40,12 +40,6 @@ USA. (define (parse-file-attributes-string string) (parse-file-attributes (string->parser-buffer string))) -(define (parse-file-attributes-line port db multiline?) - (declare (ignore db multiline?)) - ;; (parse-file-attributes - ;; (textual-input-port->parser-buffer port "-*- ")) - #f) - (define (parse-file-attributes parser-buffer) (let ((v (parse:attributes-line parser-buffer))) (and v diff --git a/src/runtime/parse.scm b/src/runtime/parse.scm index 335cdc0e6..75c0ba64a 100644 --- a/src/runtime/parse.scm +++ b/src/runtime/parse.scm @@ -302,147 +302,79 @@ USA. port db ctx char continue-parsing) +(define (start-attributes-comment port db) + (and (db-enable-attributes? db) + ;; If we're past the second line, just discard. + (let ((line (current-line port db))) + (and line + (< line 2))) + (string-builder))) + +(define (finish-attributes-comment builder port) + (let ((attributes (and builder (parse-file-attributes-string (builder))))) + (if attributes + (begin + (process-file-attributes attributes port) + restart-parsing) + continue-parsing))) + (define (handler:comment port db ctx char) (declare (ignore ctx char)) + (let ((builder (start-attributes-comment port db))) + (let walk () + (let ((char (%read-char port db))) + (cond ((eof-object? char) + (finish-attributes-comment builder port) + char) + ((char=? char #\newline) + (finish-attributes-comment builder port)) + (else + (if builder (builder char)) + (walk))))))) - ;; This is a small state machine that looks for -*- - ;; The scan state is when it hasn't found anything. - ;; The dash state is after a - has been seen. - ;; The discard state is after the file-attributes-line has - ;; been parsed. - (define (scan) - (let ((char (%read-char port db))) - (if (eof-object? char) - char - (case char - ((#\newline) continue-parsing) - ((#\-) (dash)) - (else (scan)))))) - - (define (dash) - (let ((char (%read-char port db))) - (if (eof-object? char) - char - (case char - ((#\newline) continue-parsing) - ((#\*) - (let ((char (%read-char port db))) - (if (eof-object? char) - char - (case char - ((#\newline) continue-parsing) - ((#\-) - (process-file-attributes - (parse-file-attributes-line port db false) - port) - (discard restart-parsing)) - (else (scan)))))) - ((#\-) (dash)) - (else (scan)))))) - - (define (discard action) - (let ((char (%read-char port db))) - (cond ((eof-object? char) char) - ((char=? char #\newline) action) - (else (discard action))))) - - ;; If we're past the second line, just discard. - (if (and (let ((line (current-line port db))) - (and line - (< line 2))) - (db-enable-attributes? db)) - (scan) - (discard continue-parsing))) - (define (handler:multi-line-comment port db ctx char1 char2) (declare (ignore ctx char1 char2)) - ;; In addition to parsing out the multi-line-comment, we want to - ;; extract out the file attribute line if it exists in the first - ;; line. To do this, we use a small state machine implemented as a - ;; bunch of internal functions. Each state function takes a - ;; character from the port as an input and finishes by tail-calling - ;; the next state with the next character. - - ;; These first five states are where we scan the - ;; first line looking for the file attribute marker, end of comment, - ;; nested comment, or end of line. - - (define (scan) - (case (%read-char/no-eof port db) - ((#\newline) (discard 0 continue-parsing)) - ((#\#) (sharp)) - ((#\-) (dash)) - ((#\|) (vbar)) - (else (scan)))) - - (define (sharp) - (case (%read-char/no-eof port db) - ((#\newline) (discard 0 continue-parsing)) - ((#\#) (sharp)) - ((#\-) (dash)) - ((#\|) (discard 1 continue-parsing)) ; nested comment - (else (scan)))) - - (define (vbar) - (case (%read-char/no-eof port db) - ((#\newline) (discard 0 continue-parsing)) - ((#\#) continue-parsing) ; end of comment - ((#\-) (dash)) - ((#\|) (vbar)) - (else (scan)))) - - (define (dash) - (case (%read-char/no-eof port db) - ((#\newline) (discard 0 continue-parsing)) - ((#\#) (sharp)) - ((#\*) (dash-star)) - ((#\-) (dash)) - ((#\|) (vbar)) - (else (scan)))) - - (define (dash-star) - (case (%read-char/no-eof port db) - ((#\newline) (discard 0 continue-parsing)) - ((#\#) (sharp)) - ((#\-) - (process-file-attributes (parse-file-attributes-line port db true) port) - (discard 0 restart-parsing)) - ((#\|) (vbar)) - (else (scan)))) - - ;; Next three states are the discard loop where we - ;; just track the nesting level and discard stuff. - ;; We don't look for the file-attribute marker. - - (define (discard depth action) - (case (%read-char/no-eof port db) - ((#\#) (discard-sharp depth action)) - ((#\|) (discard-vbar depth action)) - (else (discard depth action)))) - - (define (discard-sharp depth action) - (case (%read-char/no-eof port db) - ((#\#) (discard-sharp depth action)) - ((#\|) (discard (+ depth 1) action)) ; push - (else (discard depth action)))) - - (define (discard-vbar depth action) - (case (%read-char/no-eof port db) - ((#\#) (if (> depth 0) - (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 (let ((line (current-line port db))) - (and line - (< line 2))) - (db-enable-attributes? db)) - (scan) - (discard 0 continue-parsing))) + (let ((builder (start-attributes-comment port db))) + + (define (walk depth) + (let ((char (%read-char/no-eof port db))) + (case char + ((#\#) + (if builder (builder char)) + (walk-sharp depth)) + ((#\|) + (if (and builder (> depth 0)) + (builder char)) + (walk-vbar depth)) + (else + (if builder (builder char)) + (walk depth))))) + + (define (walk-sharp depth) + (let ((char (%read-char/no-eof port db))) + (if builder (builder char)) + (case char + ((#\#) (walk-sharp depth)) + ((#\|) (walk (+ depth 1))) ; push + (else (walk depth))))) + + (define (walk-vbar depth) + (let ((char (%read-char/no-eof port db))) + (case char + ((#\#) + (if (> depth 0) + (begin ; pop + (if builder (builder char)) + (walk (- depth 1))))) + ((#\|) + (if builder (builder char)) + (walk-vbar depth)) + (else + (if builder (builder char)) + (walk depth))))) + (walk 0) + (finish-attributes-comment builder port))) ;; It would be better if we could skip over the object without ;; creating it, but for now this will work. @@ -989,13 +921,11 @@ USA. object)) (define (process-file-attributes file-attribute-alist port) - (if file-attribute-alist - (begin - ;; Disable further attributes parsing. - (set-port-property! port 'parser-enable-attributes? #f) - (process-keyword-attribute file-attribute-alist port) - (process-mode-attribute file-attribute-alist port) - (process-studly-case-attribute file-attribute-alist port)))) + ;; Disable further attributes parsing. + (set-port-property! port 'parser-enable-attributes? #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 diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 33d23dfc6..bfc806f14 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -3356,9 +3356,7 @@ USA. (files "file-attributes") (parent (runtime)) (export (runtime) - parse-file-attributes-string) - (export (runtime parser) - parse-file-attributes-line)) + parse-file-attributes-string)) (define-package (runtime pathname) (files "pathnm")