es.el

es.el

;;
;; Copyright (c) 2009 Masatake YAMATO
;;
;; Permission is hereby granted, free of charge, to any person obtaining a copy
;; of this software and associated documentation files (the "Software"), to deal
;; in the Software without restriction, including without limitation the rights
;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;; copies of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;;
;;  The above copyright notice and this permission notice shall be included in
;;  all copies or substantial portions of the Software.
;;
;;  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;  IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;;  AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;  OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
;;  THE SOFTWARE.

(eval-when-compile
  (require 'cl))

;;
;; Special constants
;;
(defconst es-true  (make-symbol "#t")
  "Uninterested symbol representing true boolean value of es expression.")
(defconst es-false (make-symbol "#f")
  "Uninterested symbol representing end of input stream.")
(defconst es-eof   (make-symbol "#<EOF>")
  "OBJECT, returned from `es-read', represents end of stream.")


;;
;; Input stream
;;
(defun es-make-input-stream (seed &optional prompt)
  "Make input stream for SEED from `es-read' can read."
  (cond ((null seed)
	 (es-make-input-stream standard-input))
	((eq seed t)
	 (es-make-input-stream (read-from-minibuffer (or prompt "Es: "))))
	((or (or (bufferp seed)
		 (markerp  seed)
		 (functionp seed)
		 (symbolp seed))
	     (processp seed))
	 seed)
	((stringp seed)
	 (vector seed 0))
	))
	
      
(defun es-stream-read-char-from-buffer (buffer)
  (with-current-buffer buffer
    (let ((c (char-after)))
      (when c 
	(forward-char 1))
      c)))
(defun es-stream-unread-char-to-buffer (buffer c)
  (with-current-buffer buffer
    (let ((b (char-before)))
      (if (eq c b)
	  (backward-char 1)
	(error "unread char `%c' and char before the point in buffer `%s' are not match"
	       c (buffer-name))))))


(defun es-stream-read-char-from-marker (stream)
  (let ((buffer (marker-buffer stream))
	(pos    (marker-position stream)))
    (with-current-buffer buffer
      (let ((c (char-after pos)))
	(when c 
	  (set-marker stream (1+ pos)))
	c))))
(defun es-stream-unread-char-to-marker (stream c)
  (let ((buffer (marker-buffer stream))
	(pos    (marker-position stream)))
    (with-current-buffer buffer
      (let ((b (char-before pos)))
	(if (eq c b)
	    (set-marker (1- pos) buffer)
	  (error "unread char `%c' and char before the marker `%d' in buffer `%s' are not match"
		 c pos (buffer-name)))))))

(defun es-string-stream-p (stream)
  (and (vectorp stream)
       (or (stringp (aref stream 0)) 
	   (listp (aref stream 0)))
       (integerp (aref stream 1))))
(defun es-stream-read-char-from-string (string &optional pos)
  (let ((pos (or pos 0))
	(len (length string)))
    (if (< pos len)
	(elt string pos)
      nil)))

(defun es-stream-read-char-from-string-stream (string-stream)
  (let* ((pos (aref string-stream 1))
	 (c (es-stream-read-char-from-string (aref string-stream 0)
					     pos)))
    (unless (null c)
      (aset string-stream 1 (1+ pos)))
    c))
(defun es-stream-unread-char-to-string-stream (string-stream c)
  (let* ((pos (aref string-stream 1))
	 (string (aref string-stream 0)))
    (cond
     ((eq pos 0)
      (error "cannot seek back anymore in string-stream: `%s'"
	     string))
     ((eq (es-stream-read-char-from-string string
					   (1- pos)) c)
      (aset string-stream 1 (1- pos)))
     (t
      (error "unread char `%c' and char before the string-stream `%d' in string `%s' are not match"
	     c pos string)))))

(defun es-stream-read-char-from-function (function)
  (apply function ()))
(defun es-stream-unread-char-to-function (function c)
  (apply function c ()))
(defun es-stream-read-char-from-symbol (symbol)
  (apply 'es-stream-read-char-from-function symbol ()))
(defun es-stream-unread-char-to-symbol (symbol c)
  (apply 'es-stream-unread-char-to-function symbol c ()))

(defun es-stream-read-char (&optional stream)
  (cond
   ((bufferp stream)
    (es-stream-read-char-from-buffer stream))
   ((markerp stream)
    (es-stream-read-char-from-marker stream))
   ((functionp stream)
    (es-stream-read-char-from-function stream))
   ((symbolp stream)
    (es-stream-read-char-from-symbol stream))
   ((null stream)
    (es-stream-read-char standard-input))
   ((es-string-stream-p stream)
    (es-stream-read-char-from-string-stream stream))))

(defun es-stream-unread-char (c &optional stream)
  (cond
   ((bufferp stream)
    (es-stream-unread-char-to-buffer stream c))
   ((markerp stream)
    (es-stream-unread-char-to-marker stream c))
   ((functionp stream)
    (es-stream-unread-char-to-function stream c))
   ((symbolp stream)
    (es-stream-unread-char-to-symbol stream c))
   ((null stream)
    (es-stream-unread-char standard-input))
   ((es-string-stream-p stream)
    (es-stream-unread-char-to-string-stream stream c))))


;;
;; Reader
;;
(defun es-skip-to-newline (stream)
  (let ((c t))
    (while (not (or (null c)
		    (eq c ?\C-j)))
      (setq c (es-stream-read-char stream)))))
(defun es-is-whitespace (c)
  (memq c '(?\ ?\t ?\n ?\r ?\f)))

(defun es-get-token (stream)
  (let ((c (es-stream-read-char stream)))
    (cond
     ((null c) c)
     ((es-is-whitespace c) 
      (es-get-token stream))
     ((eq c ?\;) 
      (es-skip-to-newline stream)
      (es-get-token stream))
     ((eq c ?\()
      c)
     ((eq c ?\))
      c)
     ((eq c ?\")
      (es-get-sequence stream (list ?\") 'normal
		       'es-string-is-terminator
		       'es-string-make
		       'es-string-eof-action
		       nil))
     ((eq c ?|)
      (es-get-sequence stream (list) 'normal
		       'es-fenced-symbol-is-terminator
		       'es-fenced-symbol-make
		       'es-fenced-symbol-eof-action
		       nil))
     (t
      (es-get-sequence stream (list c) 'normal
		       'es-symbol-is-terminator
		       'es-symbol-make
		       'es-symbol-eof-action
		       t)))))

(defun es-string-is-terminator (c)
  (eq c ?\"))
(defun es-string-make (seed)
  (apply 'string seed))
(defun es-string-eof-action (seed)
  (error "met unexpected EOF during reading string"))

(defun es-fenced-symbol-is-terminator (c)
  (eq c ?|))
(defun es-fenced-symbol-make (seed)
  (intern (apply 'string seed)))
(defun es-fenced-symbol-eof-action (seed)
  (error "unexpected EOF during reading fenced symbol"))

(defun es-symbol-is-terminator (c)
  (or (es-is-whitespace c)
      (eq c ?\;)
      (eq c ?\()
      (eq c ?\))
      (eq c ?\")
      (eq c ?|)))
(defun es-symbol-make (seed)
  (let* ((str (apply 'string seed))
	 (num (string-to-number str)))
    (cond
     ((equal str "#t")
      es-true)
     ((equal str "#f")
      es-false)
     ((equal str "0") str)
     ((not (eq num 0)) str)
     (t
      (intern str)))))
(defun es-symbol-eof-action (seed)
  (es-symbol-make seed))


(defun es-get-sequence (stream seed state terminatorp maker eof-action keep-terminator)
  (let (c result)
    (while (not result)
      (setq c (es-stream-read-char stream))
      (cond
       ((funcall terminatorp c)
	(case state
	 ('normal
	  (when keep-terminator
	    (es-stream-unread-char c stream))
	  (setq result (funcall maker (reverse seed))))
	 ('escaped
	  (setq seed (cons 
		      (case c
			(?n ?\n)
			(?t ?\t)
			(?r ?\r)
			(?f ?\f)
			(t c))
		      seed)
		state 'normal))))
       ((eq c ?\\)
	(setq state 'escaped))
       ((null c)
	(setq result (apply eof-action (list (reverse seed)))))
       (t
	(setq seed (cons c seed)
	      state 'normal))
       ))
    result))

(defun es-number-string-p  (token)
  (and (stringp token)
       (or (equal token "0")
	   (not (eq (string-to-number token) 0)))))
(defun es-make-number (token)
  (string-to-number token))

(defun es-fill-list (stream seed)
  (let ((token (es-get-token stream)))
    (cond
     ((null token)
      (error "unexpected EOF during reading list"))
     ((eq token ?\))
      (reverse seed))
     ((eq token ?\()
      (let ((elt (es-fill-list stream nil)))
	(es-fill-list stream (cons elt seed))))
     ((and (stringp token) (< 0 (length token)) (eq (elt token 0) ?\"))
      (es-fill-list stream (cons (substring token 1) seed)))
     ((es-number-string-p token)
      (es-fill-list stream (cons (es-make-number token) seed)))
     (t
      (es-fill-list stream (cons token seed))))))

(defun es-read (&optional stream)
  "Read an es expression from STREAM.
If it reaches the end of STREAM, it returns `es-eof'."
  ;; TODO: Don't use recursion.
  (let ((max-lisp-eval-depth 4000))
    (cond
     ((processp stream)
      (with-current-buffer (process-buffer stream)
					;(sit-for 1)
					;(message "-")
	(save-excursion
	  (goto-char (point-min))
	  (let ((r (es-read (current-buffer))))
	    (delete-region (point-min) (point))
	    r))))
     ((stringp stream)
      (es-read (es-make-input-stream stream)))
     ((null stream)
      (es-read (es-make-input-stream nil)))
     (t
      (let ((token (es-get-token stream)))
	(cond
	 ((null token) es-eof)
	 ((eq token ?\()
	  (es-fill-list stream (list))
	  )
	 ((eq token ?\))
	  (error "unexpected close paren"))
	 ((and (stringp token) (< 0 (length token)) (eq (elt token 0) ?\"))
	  (substring token 1))
	 ((es-number-string-p token)
	  (es-make-number token))
	 (t
	  token)))))))



;;
;; Output stream
;;
(defun es-make-output-stream (seed)
  "Make output stream for SEED to which `es-print' and `es-comment' can write."
  (cond
   ((stringp seed)
    (vector (list seed) (length seed)))
   (t
    seed)))

(defun es-stream-print-chat-to-string-stream (string-stream char)
  (es-stream-print-string-to-string-stream string-stream (list char)))

(defun es-stream-print-string-to-string-stream (string-stream string)
  (aset string-stream 0 (cons string (aref string-stream 0)))
  (aset string-stream 1 (+ (aref string-stream 1) 
			   (length string)
			   ))
  string-stream)

(defun es-stream-get-string (string-stream)
  "Get the result string from output stream STRING-STREAM."
  (if (es-string-stream-p string-stream)
      (let ((s (nreverse (aref string-stream 0))))
	(aset string-stream 0 (list ""))
	(aset string-stream 1 0)
	(apply 'concat s))
    (error "string-stream is expected: %a" string-stream)))


;;
;; Printer
;;
(defun es-print-list (kar kdr stream)
  (es-print kar stream)
  (unless (null kdr)
    (es-write-char ?\  stream)
    (es-print-list (car kdr) (cdr kdr) stream)))

;; /*
;;  * symbol.c - symbol implementation
;;  *
;;  *   Copyright (c) 2000-2007  Shiro Kawai  <[email protected]>
;;  * 
;;  *   Redistribution and use in source and binary forms, with or without
;;  *   modification, are permitted provided that the following conditions
;;  *   are met:
;;  * 
;;  *   1. Redistributions of source code must retain the above copyright
;;  *      notice, this list of conditions and the following disclaimer.
;;  *
;;  *   2. Redistributions in binary form must reproduce the above copyright
;;  *      notice, this list of conditions and the following disclaimer in the
;;  *      documentation and/or other materials provided with the distribution.
;;  *
;;  *   3. Neither the name of the authors nor the names of its contributors
;;  *      may be used to endorse or promote products derived from this
;;  *      software without specific prior written permission.
;;  *
;;  *   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;  *   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;  *   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;;  *   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;;  *   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;  *   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;  *   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;;  *   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;;  *   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;  *   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;  *   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;  *
;;  *  $Id: symbol.c,v 1.40 2007/09/13 12:30:28 shirok Exp $
;;  */
;; /* table of special chars.
;;    bit 0: bad char for symbol to begin with
;;    bit 1: bad char for symbol to contain
;;    bit 2: bad char for symbol, and should be written as \nnn
;;    bit 3: bad char for symbol, and should be written as \c
;;    bit 4: may be escaped when case fold mode
;;  */
(defconst es-char-class 
  [;; /* NUL .... */
   7  7  7  7  7  7  7  7  7  7  7  7  7  7  7  7 
   ;;  /* .... */
   7  7  7  7  7  7  7  7  7  7  7  7  7  7  7  7 
   ;; /*    !  "  #  $  %  &  '  (  )  *  +  ,  -  .  /  */
   3  0  3  3  0  0  0  3  3  3  0  1  3  1  1  0 
   ;; /* 0  1  2  3  4  5  6  7  8  9  :  ;  <  =  >  ?  */
   1  1  1  1  1  1  1  1  1  1  0  3  0  0  0  0 
   ;; /* @  A  B  C  D  E  F  G  H  I  J  K  L  M  N  O  */
   1  16 16 16 16 16 16 16 16 16 16 16 16 16 16 16 
   ;; /* P  Q  R  S  T  U  V  W  X  Y  Z  [  \  ]  ^  _  */
   16 16 16 16 16 16 16 16 16 16 16 3  11 3  0  0 
   ;; /* `  a  b  c  d  e  f  g  h  i  j  k  l  m  n  o  */
   3  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0 
   ;; /* p  q  r  s  t  u  v  w  x  y  z  {  |  }  ~  ^? */
   0  0  0  0  0  0  0  0  0  0  0  3  11 3  0  7])

(defun es-get-char-class (c)
  (if (< c (length  es-char-class))
      (aref es-char-class c)
    #xff))

(defun es-print-symbol (object stream)
  (let ((list (string-to-list (symbol-name object))))
    (cond
     ((eq (length list) 0)
      (es-write-char ?| stream)
      (es-write-char ?| stream))
     (t
      (let* ((cc (es-get-char-class (car list)))
	     (needs-bar (if (eq (logand cc #x1) 1) t nil)))
	(unless needs-bar
	  (mapc (lambda (c0)
		  (unless needs-bar
		    (setq cc (es-get-char-class c0))
		    (setq needs-bar (if (eq (logand cc #x2) 1) t nil))))
		list))
	(when needs-bar
	  (es-write-char ?| stream))
	(mapc (lambda (c) 
		(when (or (eq c ?\\) (eq c ?|))
		  (es-write-char ?\\ stream))
		(es-write-char c stream)) 
	      list)
	(when needs-bar
	  (es-write-char ?| stream)))))))

(defun es-write-char (char stream)
  (cond
   ((processp stream)
    (if char
	(process-send-string stream (char-to-string char))
      (process-send-eof stream)))
   ((es-string-stream-p stream)
    (es-stream-print-chat-to-string-stream stream char))
   (t
    (write-char char stream))))

(defun es-prin1 (object stream)
  (cond
   ((processp stream)
    (prin1 object (lambda (c) (es-write-char c stream))))
   ((es-string-stream-p stream)
    (es-stream-print-string-to-string-stream stream 
					     (prin1-to-string object)))
   (t
    (prin1 object stream))))

(defun es-print (object &optional stream)
  "Print an es expression OBJECT to STREAM."
  (cond
   ((integerp object) (es-prin1 object stream))
   ((floatp object)  (es-prin1 object stream))
   ((stringp object) (es-prin1 object stream))
   ((eq object es-true) 
    (es-write-char ?# stream)
    (es-write-char ?t stream))
   ((eq object es-false) 
    (es-write-char ?# stream)
    (es-write-char ?t stream))
   ((symbolp object)
    (es-print-symbol object stream))
   ((null object)
    (es-write-char ?\( stream)
    (es-write-char ?\) stream))
   ((listp object)
    (es-write-char ?\( stream)
    ;; 
    (es-print-list (car object) (cdr object) stream)
    (es-write-char ?\) stream))))

(defun es-comment (comment &optional stream)
  "Print COMMENT to STREAM in lisp comment style.
Each line in COMMENT are printed with prefix \";;\"."
  (mapc (lambda (comment0)
	  (es-write-char ?\; stream)
	  (es-write-char ?\; stream)
	  (es-write-char ?\  stream)
	  (mapc (lambda (c)
		  (es-write-char c stream))
		comment0)
	  (es-write-char ?\n  stream))
	(split-string comment "\n")))

(provide 'es)