;;; -*- Mode: Scheme; MIT-Scheme-Package: (EDWIN) -*-

;;; This file implements a patch to Edwin for supporting more information in a
;;; buffer's -*- header than just the mode; see the above -*- header for an
;;; example of what information can be added.  The DEFINE-BUFFER-HEADER-HANDLER
;;; procedure can be used to implement new buffer header specifiers; the only
;;; one defined here is "mit-scheme-package", which sets the environment for
;;; evaluation to be that of the given named package.

;;; Simplified macro for this file only.

(define-syntax and-let*
  (syntax-rules ()

    ((AND-LET* ()
       body)
     (LET ()
       body))

    ((AND-LET* ((identifier0 expression0)
                (identifier1 expression1)
                ...)
       body)
     (COND (expression0
            => (LAMBDA (identifier0)
                 (AND-LET* ((identifier1 expression1)
                            ...)
                   body)))
           (ELSE #F)))))

;;; This replaces the PARSE-BUFFER-MODE-HEADER definition in fileio.scm.

(define (parse-buffer-mode-header buffer)
  (let* ((start (buffer-start buffer))
         (end (line-end start 0)))
    (and-let* ((start (re-search-forward "-\\*-" start end #f))
               (end   (re-search-forward "-\\*-" start end #f)))
      (cond ((char-search-forward #\: start end #f)
             => (lambda (after-colon)
                  (parse-buffer-header start end after-colon buffer)))
            (else
             (string-trim (extract-string start end)))))))

(define (parse-buffer-header start end after-colon buffer)
  (call-with-current-continuation
   (lambda (abort)

     (define (proceed after-semicolon mode)
       (cond ((and after-semicolon
                   (char-search-forward #\: after-semicolon end #f))
              => (lambda (after-colon)
                   (loop after-semicolon after-colon mode)))
             (else mode)))

     (define (with-aborting-handler mode thunk)
       (bind-condition-handler
           (list condition-type:error)
           (lambda (condition)
             (message "Error while parsing buffer -*- header of \""
                      (buffer-name buffer)
                      "\"")
             (abort mode))
         thunk))

     (define (extract-mode after-colon old-mode)
       ;; This would be the place to implement support for specifying minor
       ;; modes in the -*- line.
       ((lambda (extract)
          (cond ((char-search-forward #\; after-colon end #f)
                 => (lambda (after-semicolon)
                      (proceed after-semicolon (extract after-semicolon))))
                (else
                 (extract after-colon))))
        (lambda (after-semicolon)
          (let ((new-mode
                 (string-trim (extract-string after-colon
                                              (mark-1+ after-semicolon)))))
            (if old-mode
                (begin (message "Second mode specification: " new-mode
                                "; using original (" old-mode ")")
                       old-mode)
                new-mode)))))

     (define (loop start after-colon mode)
       ;; We must install a handler at every iteration of the loop in order to
       ;; close the handler over MODE, which may change as we proceed.
       (with-aborting-handler mode
         (lambda ()
           (let ((name (string-trim (extract-string start
                                                    (mark-1+ after-colon)))))
             (if (string-ci=? name "mode")
                 (extract-mode after-colon mode)
                 (receive (value after-value)
                          (call-with-input-region (make-region after-colon end)
                            (lambda (input-port)
                              ;; The READ must happen before we extract the
                              ;; mark.
                              (let ((value (read input-port)))
                                (values value (input-port/mark input-port)))))
                   (cond ((buffer-header-handler name)
                          => (lambda (handler)
                               (handler value buffer)))
                         (else
                          (message "Unrecognized buffer header field: " name)))
                   (proceed (skip-chars-forward " \t;" after-value end #f)
                            mode)))))))

     (loop start after-colon #f))))

(define input-port/mark
        (access input-port/mark (->environment '(EDWIN BUFFER-INPUT-PORT))))

(define buffer-header-handlers (make-string-table 10 #t))
(define (define-buffer-header-handler name handler)
  (string-table-put! buffer-header-handlers name handler))
(define (buffer-header-handler name)
  (string-table-get buffer-header-handlers name))

(define-buffer-header-handler "mit-scheme-package"
  (lambda (package buffer)
    (set-variable! scheme-environment package buffer)))



;;; Edwin Variables:
;;; Eval: (scheme-indent-method 'and-let* 1)
;;; End: