misc/fuel/fuel-eval.el

   1 ;;; fuel-eval.el --- evaluating Factor expressions
   2
   3 ;; Copyright (C) 2008, 2009  Jose Antonio Ortega Ruiz
   4 ;; See http://factorcode.org/license.txt for BSD license.
   5
   6 ;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
   7 ;; Keywords: languages
   8 ;; Start date: Tue Dec 02, 2008
   9
  10 ;;; Commentary:
  11
  12 ;; Protocols for sending evaluations to the Factor listener.
  13
  14 ;;; Code:
  15
  16 (require 'fuel-connection)
  17 (require 'fuel-log)
  18 (require 'fuel-base)
  19 (require 'factor-mode)
  20
  21 (require 'cl-lib)
  22
  23 \f
  24 ;;; Simple sexp-based representation of factor code
  25
  26 (defun factor (sexp)
  27   (cond ((null sexp) "f")
  28         ((eq sexp t) "t")
  29         ((or (stringp sexp) (numberp sexp)) (format "%S" sexp))
  30         ((vectorp sexp) (factor (cons :quotation (append sexp nil))))
  31         ((listp sexp)
  32          (cl-case (car sexp)
  33            (:array (factor--seq 'V{ '} (cdr sexp)))
  34            (:seq (factor--seq '{ '} (cdr sexp)))
  35            (:tuple (factor--seq 'T{ '} (cdr sexp)))
  36            (:quote (format "\\ %s" (factor `(:factor ,(cadr sexp)))))
  37            (:quotation (factor--seq '\[ '\] (cdr sexp)))
  38            (:using (factor `(USING: ,@(cdr sexp) :end)))
  39            (:factor (format "%s" (mapconcat 'identity (cdr sexp) " ")))
  40            (:fuel (factor--fuel-factor (cons :rs (cdr sexp))))
  41            (:fuel* (factor--fuel-factor (cons :nrs (cdr sexp))))
  42            (t (mapconcat 'factor sexp " "))))
  43         ((keywordp sexp)
  44          (factor (cl-case sexp
  45                    (:rs 'fuel-eval-restartable)
  46                    (:nrs 'fuel-eval-non-restartable)
  47                    (:in (or (factor-current-vocab) "fuel"))
  48                    (:usings `(:array ,@(factor-usings)))
  49                    (:end '\;)
  50                    (t `(:factor ,(symbol-name sexp))))))
  51         ((symbolp sexp) (symbol-name sexp))))
  52
  53 (defsubst factor--seq (begin end forms)
  54   (format "%s %s %s" begin (if forms (factor forms) "") end))
  55
  56 (defsubst factor--fuel-factor (sexp)
  57   (factor `(,(factor--fuel-restart (nth 0 sexp))
  58             ,(factor--fuel-lines (nth 1 sexp))
  59             ,(factor--fuel-in (nth 2 sexp))
  60             ,(factor--fuel-usings (nth 3 sexp))
  61             fuel-eval-in-context)))
  62
  63 (defsubst factor--fuel-restart (rs)
  64   (unless (member rs '(:rs :nrs))
  65     (error "Invalid restart spec (%s)" rs))
  66   rs)
  67
  68 (defsubst factor--fuel-lines (lst)
  69   (cons :array (mapcar 'factor lst)))
  70
  71 (defsubst factor--fuel-in (in)
  72   (cond ((or (eq in :in) (null in)) :in)
  73         ((eq in 'f) 'f)
  74         ((eq in 't) "fuel")
  75         ((stringp in) in)
  76         (t (error "Invalid 'in' (%s)" in))))
  77
  78 (defsubst factor--fuel-usings (usings)
  79   (cond ((or (null usings) (eq usings :usings)) :usings)
  80         ((eq usings t) nil)
  81         ((listp usings) `(:array ,@usings))
  82         (t (error "Invalid 'usings' (%s)" usings))))
  83
  84 \f
  85 ;;; Code sending:
  86
  87 (defvar fuel-eval--default-proc-function nil)
  88 (defsubst fuel-eval--default-proc ()
  89   (and fuel-eval--default-proc-function
  90        (funcall fuel-eval--default-proc-function)))
  91
  92 (defvar fuel-eval--proc nil)
  93
  94 (defvar fuel-eval--sync-retort nil)
  95
  96 (defun fuel-eval--send/wait (code &optional timeout buffer)
  97   (setq fuel-eval--sync-retort nil)
  98   (fuel-con--send-string/wait (or fuel-eval--proc (fuel-eval--default-proc))
  99                               (if (stringp code) code (factor code))
 100                               #'(lambda (s)
 101                                  (setq fuel-eval--sync-retort
 102                                        (fuel-eval--parse-retort s)))
 103                               timeout
 104                               buffer)
 105   fuel-eval--sync-retort)
 106
 107 (defun fuel-eval--send (code cont &optional buffer)
 108   (fuel-con--send-string (or fuel-eval--proc (fuel-eval--default-proc))
 109                          (if (stringp code) code (factor code))
 110                          `(lambda (s) (,cont (fuel-eval--parse-retort s)))
 111                          buffer))
 112
 113 \f
 114 ;;; Retort and retort-error datatypes:
 115
 116 (defsubst fuel-eval--retort-make (err result &optional output)
 117   (list err result output))
 118
 119 (defsubst fuel-eval--retort-error (ret) (nth 0 ret))
 120 (defsubst fuel-eval--retort-result (ret) (nth 1 ret))
 121 (defsubst fuel-eval--retort-output (ret) (nth 2 ret))
 122
 123 (defun fuel-eval--retort-result-safe (ret)
 124   "Retort result or throws an error if the retort error is set."
 125   (let ((err (fuel-eval--retort-error ret)))
 126     (when err (error "%s" err))
 127     (fuel-eval--retort-result ret)))
 128
 129 (defsubst fuel-eval--retort-p (ret)
 130   (and (listp ret) (= 3 (length ret))))
 131
 132 (defun fuel-eval--parse-retort (ret)
 133   (fuel-log--info "RETORT: %S" ret)
 134   (if (fuel-eval--retort-p ret)
 135       ret
 136     (list ret nil nil)))
 137
 138 (defsubst fuel-eval--error-name (err) (car err))
 139
 140 (defun fuel-eval--error-name-p (err name)
 141   (unless (null err)
 142     (or (and (eq (fuel-eval--error-name err) name) err)
 143         (assoc name err))))
 144
 145 (defsubst fuel-eval--error-restarts (err)
 146   (alist-get :restarts (or (fuel-eval--error-name-p err 'condition)
 147                            (fuel-eval--error-name-p err 'lexer-error))))
 148
 149 (defsubst fuel-eval--error-file (err)
 150   (nth 1 (fuel-eval--error-name-p err 'source-file-error)))
 151
 152 (defsubst fuel-eval--error-lexer-p (err)
 153   (or (fuel-eval--error-name-p err 'lexer-error)
 154       (fuel-eval--error-name-p (fuel-eval--error-name-p err 'source-file-error)
 155                                'lexer-error)))
 156
 157 (defsubst fuel-eval--error-line/column (err)
 158   (let ((err (fuel-eval--error-lexer-p err)))
 159     (cons (nth 1 err) (nth 2 err))))
 160
 161 (defsubst fuel-eval--error-line-text (err)
 162   (nth 3 (fuel-eval--error-lexer-p err)))
 163
 164 \f
 165 (provide 'fuel-eval)
 166 ;;; fuel-eval.el ends here