--- /dev/null
+#| -*- 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 -*-*-
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)
+\f
+(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)
+\f
;; 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)
(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)
(make-shared-objects)
(position-operation port environment)
(port/operation port 'DISCRETIONARY-WRITE-CHAR)
+ (port/operation port 'INPUT-LINE)
'())))
(define (position-operation port environment)
(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
projects / mit-scheme.git / commitdiff