;; $Id$
;; stklos scheme mode
;;
;; .emacs:
;; (autoload 'stklos-mode "stklos-mode" nil t)
;; (add-to-list 'auto-mode-alist '("\\.stk$" . stklos-mode))))
;; (defun stklos () (interactive) (run-scheme "stklos"))

(load "r5rs")

(defun stklos-eval-buffer ()
  "Evaluate the buffer with stklos"
  (interactive)
  (shell-command-on-region (point-min) (point-max) "stklos"))

;; FIXME must be called as: stklos-compile -o FILE.ostk FILE.stk
;; (defun stklos-compile-buffer ()
;;   "Compile the buffer with stklos-compile"
;;   (interactive)
;;   (save-buffer)
;;   (shell-command (concat "stklos-compile " (buffer-name))))

(defun stklos-info ()
  (interactive)
  (info "stklos"))

;; ((gauche-form number-of-special-subforms) ...)
(defvar stklos-extra-syntax
  '((call-with-input-file 1)
    (call-with-input-string 1)
    (call-with-output-file 1)
    (call-with-output-string 0)
    (call-with-values 1)
    (dotimes 1)
    (dynamic-wind 0)
    (fluid-let 1)
    (match-case 1)
    (match-lambda 1)
    (receive 2)
    (unless 1)
    (until 1)
    (values 1)
    (when 1)
    (while 1)
    (with-input-from-file 1)
    (with-input-from-string 1)
    (with-output-to-file 1)
    (with-output-to-string 1)))

;; gauche-isms
;;     (and-let* 1)
;;     (dolist 1)
;;     (dotimes 1)
;;     (if-match 2)
;;     (let*-values 1)
;;     (let-keywords* 2)
;;     (let-match 2)
;;     (let-optionals* 2)
;;     (let-syntax 1)
;;     (let-values 1)
;;     (let1 2)
;;     (letrec-syntax 1)
;;     (make 1)
;;     (multiple-value-bind 2)
;;     (parameterize 1)
;;     (parse-options 1)
;;     (receive 2)
;;     (rxmatch-case 1)
;;     (rxmatch-cond 0)
;;     (rxmatch-if 2)
;;     (rxmatch-let 2)
;;     (syntax-rules 1)
;;     (unless 1)
;;     (until 1)
;;     (when 1)
;;     (while 1)
;;     (with-builder 1)
;;     (with-error-handler 1)
;;     (with-input-from-string 1)
;;     (with-iterator 1)
;;     (with-module 1)

(defun stklos-multiline-comment-matcher (limit)
  (when (re-search-forward "^#|\n" limit t)
    (let ((beg (match-beginning 0)) end)
      (if (re-search-forward "^|#\n" limit t)
          (setq end (match-end 0))
        (setq end (point)))
      (store-match-data (list beg end))
      t)))

(define-derived-mode stklos-mode scheme-mode "stklos"
  ;; indentation:
  ;; (put 'form 'scheme-indent-function number-of-special-subforms)
  (dolist (syn stklos-extra-syntax)
    (put (car syn) 'scheme-indent-function (cadr syn)))
  ;; font-lock
  (font-lock-add-keywords
   'stklos-mode
   (eval-when-compile
     (list
      ;; stklos-specific forms from the indent list
      (cons (concat "(" (regexp-opt (mapcar (lambda (x)
                                              (symbol-name (car x)))
                                            stklos-extra-syntax) t)
                    "\\>") 1)
      ;; r5rs-standard-procedures
      (cons (concat "(" (regexp-opt (mapcar 'symbol-name
                                            r5rs-standard-procedures) t)
                    "\\>") '(1 font-lock-variable-name-face))
      ;; additional stklos-specific forms
      (cons (concat "(" (regexp-opt
                         '("require" "provide" "import" "export") t)
                    "\\>") 1)
      ;; multiline-comment
      '(stklos-multiline-comment-matcher (0 font-lock-comment-face))
      ;; regular expressions
      ;;'("#/.*?/" (0 font-lock-builtin-face t))
      )))

  ;; keymap
  (define-key stklos-mode-map [(control c) (control c)] 'comment-region)
  ;;(define-key stklos-mode-map [(control c) c] 'stklos-compile-buffer)
  (define-key stklos-mode-map [(meta return)] 'stklos-eval-buffer))