misc/fuel/fuel-eval.el

   1 ;;; fuel-eval.el --- evaluating Factor expressions
   2
   3 ;; Copyright (C) 2008  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-base)
  17 (require 'fuel-syntax)
  18 (require 'fuel-connection)
  19
  20 \f
  21 ;;; Simple sexp-based representation of factor code
  22
  23 (defun factor (sexp)
  24   (cond ((null sexp) "f")
  25         ((eq sexp t) "t")
  26         ((or (stringp sexp) (numberp sexp)) (format "%S" sexp))
  27         ((vectorp sexp) (cons :quotation (append sexp nil)))
  28         ((listp sexp)
  29          (case (car sexp)
  30            (:array (factor--seq 'V{ '} (cdr sexp)))
  31            (:quote (format "\\ %s" (factor `(:factor ,(cadr sexp)))))
  32            (:quotation (factor--seq '\[ '\] (cdr sexp)))
  33            (:factor (format "%s" (mapconcat 'identity (cdr sexp) " ")))
  34            (:fuel (factor--fuel-factor (cons :rs (cdr sexp))))
  35            (:fuel* (factor--fuel-factor (cons :nrs (cdr sexp))))
  36            (t (mapconcat 'factor sexp " "))))
  37         ((keywordp sexp)
  38          (factor (case sexp
  39                    (:rs 'fuel-eval-restartable)
  40                    (:nrs 'fuel-eval-non-restartable)
  41                    (:in (fuel-syntax--current-vocab))
  42                    (:usings `(:array ,@(fuel-syntax--usings-update)))
  43                    (:get 'fuel-eval-set-result)
  44                    (t `(:factor ,(symbol-name sexp))))))
  45         ((symbolp sexp) (symbol-name sexp))))
  46
  47 (defsubst factor--seq (begin end forms)
  48   (format "%s %s %s" begin (if forms (factor forms) "") end))
  49
  50 (defsubst factor--fuel-factor (sexp)
  51   (factor `(,(factor--fuel-restart (nth 0 sexp))
  52             ,(factor--fuel-lines (nth 1 sexp))
  53             ,(factor--fuel-in (nth 2 sexp))
  54             ,(factor--fuel-usings (nth 3 sexp))
  55             fuel-eval-in-context)))
  56
  57 (defsubst factor--fuel-restart (rs)
  58   (unless (member rs '(:rs :nrs))
  59     (error "Invalid restart spec (%s)" rs))
  60   rs)
  61
  62 (defsubst factor--fuel-lines (lst)
  63   (cons :array (mapcar 'factor lst)))
  64
  65 (defsubst factor--fuel-in (in)
  66   (cond ((null in) :in)
  67         ((eq in t) "fuel-scratchpad")
  68         ((stringp in) in)
  69         (t (error "Invalid 'in' (%s)" in))))
  70
  71 (defsubst factor--fuel-usings (usings)
  72   (cond ((null usings) :usings)
  73         ((eq usings t) nil)
  74         ((listp usings) `(:array ,@usings))
  75         (t (error "Invalid 'usings' (%s)" usings))))
  76
  77
  78 \f
  79 ;;; Code sending:
  80
  81 (defvar fuel-eval--default-proc-function nil)
  82 (defsubst fuel-eval--default-proc ()
  83   (and fuel-eval--default-proc-function
  84        (funcall fuel-eval--default-proc-function)))
  85
  86 (defvar fuel-eval--proc nil)
  87
  88 (defvar fuel-eval--sync-retort nil)
  89
  90 (defun fuel-eval--send/wait (code &optional timeout buffer)
  91   (setq fuel-eval--sync-retort nil)
  92   (fuel-con--send-string/wait (or fuel-eval--proc (fuel-eval--default-proc))
  93                               (if (stringp code) code (factor code))
  94                               '(lambda (s)
  95                                  (setq fuel-eval--sync-retort
  96                                        (fuel-eval--parse-retort s)))
  97                               timeout
  98                               buffer)
  99   fuel-eval--sync-retort)
 100
 101 (defun fuel-eval--send (code cont &optional buffer)
 102   (fuel-con--send-string (or fuel-eval--proc (fuel-eval--default-proc))
 103                          (if (stringp code) code (factor code))
 104                          `(lambda (s) (,cont (fuel-eval--parse-retort s)))
 105                          buffer))
 106
 107 \f
 108 ;;; Retort and retort-error datatypes:
 109
 110 (defsubst fuel-eval--retort-make (err result &optional output)
 111   (list err result output))
 112
 113 (defsubst fuel-eval--retort-error (ret) (nth 0 ret))
 114 (defsubst fuel-eval--retort-result (ret) (nth 1 ret))
 115 (defsubst fuel-eval--retort-output (ret) (nth 2 ret))
 116
 117 (defsubst fuel-eval--retort-p (ret) (listp ret))
 118
 119 (defsubst fuel-eval--make-parse-error-retort (str)
 120   (fuel-eval--retort-make (cons 'fuel-parse-retort-error str) nil))
 121
 122 (defun fuel-eval--parse-retort (str)
 123   (save-current-buffer
 124     (condition-case nil
 125         (let ((ret (car (read-from-string str))))
 126           (if (fuel-eval--retort-p ret) ret (error)))
 127       (error (fuel-eval--make-parse-error-retort str)))))
 128
 129 (defsubst fuel-eval--error-name (err) (car err))
 130
 131 (defsubst fuel-eval--error-restarts (err)
 132   (cdr (assoc :restarts (fuel-eval--error-name-p err 'condition))))
 133
 134 (defun fuel-eval--error-name-p (err name)
 135   (unless (null err)
 136     (or (and (eq (fuel-eval--error-name err) name) err)
 137         (assoc name err))))
 138
 139 (defsubst fuel-eval--error-file (err)
 140   (nth 1 (fuel-eval--error-name-p err 'source-file-error)))
 141
 142 (defsubst fuel-eval--error-lexer-p (err)
 143   (or (fuel-eval--error-name-p err 'lexer-error)
 144       (fuel-eval--error-name-p (fuel-eval--error-name-p err 'source-file-error)
 145                                'lexer-error)))
 146
 147 (defsubst fuel-eval--error-line/column (err)
 148   (let ((err (fuel-eval--error-lexer-p err)))
 149     (cons (nth 1 err) (nth 2 err))))
 150
 151 (defsubst fuel-eval--error-line-text (err)
 152   (nth 3 (fuel-eval--error-lexer-p err)))
 153
 154 \f
 155 (provide 'fuel-eval)
 156 ;;; fuel-eval.el ends here