From: Joe Marshall Date: Wed, 24 Mar 2010 23:48:44 +0000 (-0700) Subject: Add stub file-attributes-line parser and hook into scheme parser. X-Git-Tag: 20100708-Gtk~71^2~29 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6882f52bc921fc39e40c968ff6c5569ac5c591ea;p=mit-scheme.git Add stub file-attributes-line parser and hook into scheme parser. --- diff --git a/src/runtime/file-attributes.scm b/src/runtime/file-attributes.scm new file mode 100644 index 000000000..3f4384c86 --- /dev/null +++ b/src/runtime/file-attributes.scm @@ -0,0 +1,91 @@ +#| -*- Mode: Scheme -*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; File attributes parser +;;; package: (runtime parser file-attributes) + +(declare (usual-integrations)) + +;;; This file 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. + +#||-*- mode:lisp; + package:(FOOBAR :USE (GLOBAL BAZ) + :SHADOW (CAR CDR CONS)); + base:10 + -*- ||# + +;;; -*- Mode: Java; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 2 -*- */ + +;;; -*- Mode: C; tab-width: 4; -*- */ + +;;; -*-mode:C;tab-width:3-*- + +;;; For Emacs: -*- mode:cperl; mode:folding -*- + +;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- + +;;; -*-mode:C;tab-width:3-*- + +;;; -*-mode:c; c-style:k&r; c-basic-offset:4; -*- */ + +;;;-*-Mode:LISP;Syntax: Common-Lisp;Package:ib;Base:10-*- + +;;;-*-mode:lisp;parser:read-*- + +;;; -*-Mode:Perl; perl-indent-level:8-*- + +;;; -*-mode:JavaScript;coding:latin-1;-*- Time-stamp: "2006-08-09 16:18:45 ADT" + +;;; -*- Mode: C; indent-tabs-mode:nil; c-basic-offset: 8-*- */ + +;;; -*- coding:utf-8;mode:python;mode:font-lock -*- + +;;; -*- test-case-name: twisted.test.test_htb -*- + +;;; -*- mode: C; c-file-style: "gnu" -*- + +;;;-*- syntax:COMMON-LISP; Package: (ITERATE :use "COMMON-LISP" :colon-mode :external) -*- + +;;; -*- package IDE-ini -*- + +;;; -*- Mode: Emacs-Lisp; outline-regexp: " \n;;;;+" -*- + +;;; It should surprise no one that the following comes from a python file. +;;; -*-*- encoding: utf-8 -*-*- diff --git a/src/runtime/parse.scm b/src/runtime/parse.scm index 83a50e986..f4e5136e0 100644 --- a/src/runtime/parse.scm +++ b/src/runtime/parse.scm @@ -184,33 +184,141 @@ USA. continue-parsing) (define (handler:comment port db ctx char) - ctx char - (let loop () + (declare (ignore ctx char)) + + ;; 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) unspecific) + ((#\-) (dash)) + (else (scan)))))) + + (define (dash) + (let ((char (%read-char port db))) + (if (eof-object? char) + char + (case char + ((#\newline) unspecific) + ((#\*) + (let ((char (%read-char port db))) + (if (eof-object? char) + char + (case char + ((#\newline) unspecific) + ((#\-) + (parse-file-attributes-line port db false) + (discard)) + (else (scan)))))) + ((#\-) (dash)) + (else (scan)))))) + + (define (discard) (let ((char (%read-char port db))) (cond ((eof-object? char) char) ((char=? char #\newline) unspecific) - (else (loop))))) + (else (discard))))) + + ;; If we're past the second line, just discard. + (if (< (current-line port db) 2) + (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)) + ((#\#) (sharp)) + ((#\-) (dash)) + ((#\|) (vbar)) + (else (scan)))) -(define (handler:multi-line-comment port db ctx char1 char2) - ctx char1 char2 - (let loop () + (define (sharp) (case (%read-char/no-eof port db) - ((#\#) - (let sharp () - (case (%read-char/no-eof port db) - ((#\#) (sharp)) - ((#\|) (loop) (loop)) - (else (loop))))) - ((#\|) - (let vbar () - (case (%read-char/no-eof port db) - ((#\#) unspecific) - ((#\|) (vbar)) - (else (loop))))) - (else (loop)))) - continue-parsing) + ((#\newline) (discard 0)) + ((#\#) (sharp)) + ((#\-) (dash)) + ((#\|) (discard 1)) ; nested comment + (else (scan)))) + (define (vbar) + (case (%read-char/no-eof port db) + ((#\newline) (discard 0)) + ((#\#) unspecific) ; end of comment + ((#\-) (dash)) + ((#\|) (vbar)) + (else (scan)))) + + (define (dash) + (case (%read-char/no-eof port db) + ((#\newline) (discard 0)) + ((#\#) (sharp)) + ((#\*) (dash-star)) + ((#\-) (dash)) + ((#\|) (vbar)) + (else (scan)))) + + (define (dash-star) + (case (%read-char/no-eof port db) + ((#\newline) (discard 0)) + ((#\#) (sharp)) + ((#\-) (parse-file-attributes-line port db true) (discard 0)) + ((#\|) (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) + (case (%read-char/no-eof port db) + ((#\#) (discard-sharp depth)) + ((#\|) (discard-vbar depth)) + (else (discard depth)))) + + (define (discard-sharp depth) + (case (%read-char/no-eof port db) + ((#\#) (discard-sharp depth)) + ((#\|) (discard (+ depth 1))) ; push + (else (discard depth)))) + + (define (discard-vbar depth) + (case (%read-char/no-eof port db) + ((#\#) (if (> depth 0) + (discard (- depth 1)) ; pop + unspecific)) + ((#\|) (discard-vbar depth)) + (else (discard depth)))) + + ;; Start the machine. + ;; If we're past the second line, just discard. + (if (< (current-line port db) 2) + (scan) + (discard 0)) + + continue-parsing) + ;; It would be better if we could skip over the object without ;; creating it, but for now this will work. (define (handler:expression-comment port db ctx char1 char2) @@ -635,6 +743,7 @@ USA. (shared-objects #f read-only #t) (get-position #f read-only #t) (discretionary-write-char #f read-only #t) + (input-line #f read-only #t) position-mapping) (define (initial-db port environment) @@ -653,6 +762,7 @@ USA. (make-shared-objects) (position-operation port environment) (port/operation port 'DISCRETIONARY-WRITE-CHAR) + (port/operation port 'INPUT-LINE) '()))) (define (position-operation port environment) @@ -665,6 +775,9 @@ USA. (define-integrable (current-position port db) ((db-get-position db) port)) +(define-integrable (current-line port db) + ((db-input-line db) port)) + (define-integrable (record-object-position! position object db) (if (and position (object-pointer? object)) (set-db-position-mapping! db diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index e5525005d..2ac53a14a 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -2793,6 +2793,13 @@ USA. char-set/symbol-quotes) (initialization (initialize-package!))) +(define-package (runtime parser file-attributes) + (files "file-attributes") + (parent (runtime parser)) + (export (runtime parser) + parse-file-attributes-line) + (initialization (initialize-package!))) + (define-package (runtime parser-table) (files "partab") (parent (runtime))