29 сентября 2011

Common Lisp. Embedded Maxima.

Оказалось все очень просто. Для того, чтобы встроить Maxim'у в свою программу достаточно скачать исходный код и действовать по инструкции INSTALL.lisp. В результате мы получим функцию cl-user::run, которую потом обернем в поток.

Пример команд для sbcl с установленным quicklisp.
$ git clone --depth 1 git://maxima.git.sourceforge.net/gitroot/maxima/maxima
$ cd maxima
$ sbcl 

* (load "configure.lisp")
* (confiure)
;; При необходимости измените настройки по-умолчанию
* (quit)

$ cd src/
$ sbcl

* (load "maxima-build.lisp")
* (maxima-load)
* (cl-user::run)


Такая "хитрая" загрузка реализована с помощью данного проекта http://rpgoldman.real-time.com/lisp/defsystem.html, и видимо используется по историческим причинам. Описание пакета можно посмотреть в файле src/maxima.system

Теперь необходимо обернуть функцию cl-user::run в поток. Для этого будут использоваться bordeaux-threads. Однако, прежде чем это сделать, необходимо перенаправить потоки ввода и вывода. Просмотрев clhs, я не понял как это сделать. С какими объектами необходимо связать переменные *standard-input/output*? Попробовал string-input/output-stream и все они не давали нужную функциональность, кроме того необходимо было обеспечить потокобезопасность записи/чтения из общего буфера.
Поискав в форуме comp.lang.lisp я нашел небольшую зацепку, а точнее нашел половину реализации необходимого мне класса
http://groups.google.com/group/comp.lang.lisp/tree/browse_frm/thread/521f8553b003d916/f787c820ba323a71?rnum=1&q=redirect+*standard-input*&_done=%2Fgroup%2Fcomp.lang.lisp%2Fbrowse_frm%2Fthread%2F521f8553b003d916%3Ftvc%3D1%26q%3Dredirect%2B*standard-input*%26#doc_60988c96f64e10dd

Мне оставалось только сделать класс потока двунаправленным и обезопасить его мьютексами.

(defclass oi-buffer-stream (sb-gray:fundamental-character-input-stream sb-gray:fundamental-character-output-stream)
  ((buffer :initform nil :accessor buffer)
   (lock :initform (bt:make-lock) :accessor lock)
   (cond-var :initform (bt:make-condition-variable :name "inout") :accessor cond-var)))

(defmethod sb-gray:stream-write-char :before ((s oi-buffer-stream) character)
  (declare (ignore character))
  (bt:acquire-lock (lock s) T))

(defmethod sb-gray:stream-write-char ((s oi-buffer-stream) character)
  (setf (buffer s) (concatenate 'string (buffer s) (list character)))
  (bt:condition-notify (cond-var s)))

(defmethod sb-gray:stream-write-char :after ((s oi-buffer-stream) character)
  (declare (ignore character))
  (bt:release-lock (lock s)))

(defmethod sb-gray:stream-write-string :before ((s oi-buffer-stream) string &optional start end)
  (declare (ignore start end))
  (bt:acquire-lock (lock s) T))

(defmethod sb-gray:stream-write-string ((s oi-buffer-stream) string &optional (start 0) (end (length string)))
  (setf (buffer s) (concatenate 'string (buffer s) (subseq string start end)))
  (bt:condition-notify (cond-var s)))

(defmethod sb-gray:stream-write-string :after ((s oi-buffer-stream) string &optional start end)
  (declare (ignore start end))
  (bt:release-lock (lock s)))


(defmethod sb-gray:stream-read-char :before ((s oi-buffer-stream))
  (bt:acquire-lock (lock s) T)
  (unless (buffer s) (bt:condition-wait (cond-var s) (lock s))))

(defmethod sb-gray:stream-read-char ((s oi-buffer-stream))
  (let* ((l (length (buffer s)))
         (c (when (> l 0) (elt (buffer s) 0)))
         (rest (when (> l 0) (subseq (buffer s) 1))))
    (if c (progn 
            (if (= (length (buffer s)) 0) (setf (buffer s) nil)
                (setf (buffer s) rest))
            c)
        (progn (setf (buffer s) nil) :eof))))

(defmethod sb-gray:stream-read-char :after ((s oi-buffer-stream))
  (bt:release-lock (lock s)))

(defmethod sb-gray:stream-read-char-no-hang :before ((s oi-buffer-stream))
  (bt:acquire-lock (lock s) T))

(defmethod sb-gray:stream-read-char-no-hang ((s oi-buffer-stream))
  (let* ((l (length (buffer s)))
         (c (when (> l 0) (elt (buffer s) 0)))
         (rest (when (> l 0) (subseq (buffer s) 1))))
    (if c (progn (setf (buffer s) rest)
                 (when (= (length (buffer s)) 0) (setf (buffer s) nil))
                 c)
        (progn (setf (buffer s) nil) nil))))

(defmethod sb-gray:stream-read-char-no-hang :after ((s oi-buffer-stream))
  (bt:release-lock (lock s)))

(defmethod sb-gray:stream-unread-char :before ((s oi-buffer-stream) c)
  (bt:acquire-lock (lock s) T))

(defmethod sb-gray:stream-unread-char ((s oi-buffer-stream) c)
  (let ((new (make-string (1+ (length (buffer s))))))
    (setf (elt new 0) c)
    (setf (subseq new 1) (buffer s))
    (setf (buffer s) new)))

(defmethod sb-gray:stream-unread-char :after ((s oi-buffer-stream) c)
  (bt:release-lock (lock s)))

(defmethod sb-gray:stream-read-line :before ((s oi-buffer-stream))
  (bt:acquire-lock (lock s) T)
  (unless (buffer s) (bt:condition-wait (cond-var s) (lock s))))

(defmethod sb-gray:stream-read-line ((s oi-buffer-stream))
   (let ((what (buffer s)))
        (setf (buffer s) nil)
        (if what what
            nil)))

(defmethod sb-gray:stream-read-line :after ((s oi-buffer-stream))
  (bt:release-lock (lock s)))

Использовать его можно так:

(defvar in (make-instance 'oi-buffer-stream))
(defvar out (make-instance 'oi-buffer-stream))

(defun maxima-thread ()
  (let ((*standard-input* in)
        (*standard-output* out))
    (cl-user::run)))

(defvar maxima-thread (bt:make-thread 'maxima-thread :name "maxima-thread"))

(read-line  out)
(write-string "\"Привет мир\";" in)
(read-line  out)


Вопрос: как избавиться от символа sb-gray, есть ли кросс-cl-машинный символ для gray-streams?

2 комментария:

  1. > Вопрос: как избавиться от символа sb-gray, есть ли кросс-cl-машинный символ для gray-streams?

    см. trivial-gray-streams

    ОтветитьУдалить