cl-mushcode/eval.lisp at master · nbaum/cl-mushcode · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133

(declaim (ftype function
                eval-function
                eval-expression))

(defvar *eval-function-required* nil)

(defmacro define-evaluator (name lambda-list &body forms)
  `(defun ,name (input &optional output &rest args)
     (flet ((,name ,lambda-list ,@forms))
       (cond
        ((and (stringp input) (null output))
         (with-output-to-string (output)
           (with-input-from-string (input input)
             (apply #',name input output args))))
        ((stringp input)
         (with-input-from-string (input input)
           (apply #',name input output args)))
        ((null output)
         (with-output-to-string (output)
           (apply #',name input output args)))
        (t
         (apply #',name input output args))))))

(define-evaluator eval-argument (input output &optional terms)
  (let ((*eval-function-required* nil))
    (eval-function input output terms)))

(define-evaluator scan-argument (input output &optional terms)
  (loop
    (let ((c (read-char input nil nil)))
      (when (member c (cons nil terms))
        (return-from scan-argument c))
      (when c
        (write-char c output))
      (case c
        (#\[
         (let ((c (scan-argument input output '(#\]))))
           (when c
             (write-char c output))))
        (#\{
         (let ((c (scan-argument input output '(#\}))))
           (when c
             (write-char c output))))
        (#\(
         (let ((c (scan-argument input output '(#\)))))
           (when c
             (write-char c output))))
        ((#\\ #\%)
         (let ((c (read-char input nil nil)))
           (when c
             (write-char c output))))))))

(define-evaluator eval-function (input output &optional terms)
  (let* ((string-stream (make-string-output-stream))
         (char (eval-expression input string-stream (cons #\( terms)))
         (function (get-output-stream-string string-stream)))
    (unless (eq char #\()
      ;; Not a real function.
      (write-string function output)
      (return-from eval-function char))
    (let* ((arguments nil)
           (fsym (find-symbol (string-upcase function) :lmf)))
      (unless (fboundp fsym)
        (when *eval-function-required*
          (return-from eval-function
            (prog1
              (eval-expression input (make-broadcast-stream) terms)
              (format output "#-1 FUNCTION (~:@(~A~)) NOT FOUND" function))))
        (write-string function output)
        (write-char char output)
        (return-from eval-function (eval-expression input output terms)))
      (loop
       (peek-char t input)
        (setf char
              (if (get fsym :noeval)
                  (scan-argument input string-stream '(#\, #\)))
                (eval-argument input string-stream '(#\, #\)))))
        (push (get-output-stream-string string-stream) arguments)
        (unless (eq char #\,)
          ;; Last argument.
          (return)))
      ;; Reverse the argument list.
      (setf arguments (nreverse arguments))
      (unless (or (cdr arguments)
                  (< 0 (length (car arguments))))
        (setf arguments nil))
      (let ((*standard-output* output))
        (apply fsym arguments))
      ;; Evaluate the postscript.
      (eval-expression input output terms)
      )))

(define-evaluator eval-substitution (input output &optional terms)
  (declare (ignore terms))
  (let ((c (read-char input nil nil)))
    (case c
      ((nil))
      ((#\B #\b)
       (write-char #\Space output))
      ((#\R #\r)
       (write-char #\Newline output))
      ((#\( #\) #\{ #\} #\[ #\] #\,)
       (write-char c output))
      ((#\i)
       (let ((c (read-char input nil nil)))
         (write-string (elt *itext-stack* (position c "0123456789")) output)))
      (t
       (warn "deprecation: undefined substitution %~A is treated like \\~@*~A" c)
       (write-char c output))
      )))

(define-evaluator eval-expression (input output &optional terms)
  (loop
    (let ((c (read-char input nil nil)))
      (when (member c (cons nil terms))
        (return-from eval-expression c))
      (case c
        (#\[
         (let ((*eval-function-required* t))
           (eval-function input output '(#\]))))
        (#\{
         (eval-expression input output '(#\})))
        #|(#\(
        (eval-expression input output '(#\))))|#
        (#\\
         (let ((c (read-char input nil nil)))
           (when c
             (write-char c output))))
        (#\%
         (eval-substitution input output nil))
        (t
         (write-char c output))))))