A call-limited evaluator for Lisp-style symbolic expressions with zero-argument and one-argument tag-based modules (see http://hampshire.edu/lspector/tags-gecco-2011/)

eval_with_tagging_with_args.clj

(ns eval_with_tagging_with_args)

;; A call-limited evaluator for Lisp-style symbolic expressions with zero-argument 
;; and one-argument tag-based modules (see http://hampshire.edu/lspector/tags-gecco-2011/)
;; Lee Spector, lspector@hampshire.edu, 20120121

(def tagdo-semantics true)

(defn closest-association
  "Returns the value for the closest match to the given tag in the given tag space, with
   default-value returned if the tag-space is empty."
  [tag tag-space default-value]
  (if (empty? tag-space)
    default-value
    (loop [associations (conj (vec tag-space) (first tag-space))] ;; conj does wrap
      (if (or (empty? (rest associations))
              (<= tag (ffirst associations)))
        (second (first associations))
        (recur (rest associations))))))

(defn eval-with-tagging
  "Returns the result of evaluating expression with the provided step-limit and 
   constants (which should be a map of symbols to values). The provided default-value
   is returned both for tag references that occur before any values have been tagged 
   and for tagging operations (unless tagdo-semantics is true, in which case the 
   argument to the tagging operation is evaluated and its value is returned). If the
   step-limit is exceeded then :limit-exceeded is returned. Tagging is accomplished 
   by means of an item in function position of the form {:tag n} where n is an integer,
   and where the single argument paired with this 'function' is the item to be tagged.
   Tag references look like zero-argument function calls but with a function of the 
   form {:tagged n} where n is an integer. An alternative tag reference is a one-argument
   function call with a function of the form {:tagged-with-arg n :arg m}; here the code in
   the argument position of the call will be tagged (without evaluation) with m before 
   branching to the code retrieved via tag n. Tag references within the retrieved call 
   may then, if they have appropriate tags, refer to the passed argument. In the context
   of boolean values the evaluator supports an 'if' form that takes three arguments: a
   condition, an if-true clause, and an if-false clause."
  ([expression step-limit constants default-value]
    (first (eval-with-tagging expression (sorted-map) step-limit constants default-value)))
  ([expression tag-space step-limit constants default-value] 
    ;; these calls return [value tag-space steps-remaining]
    (if (<= step-limit 0)
      [:limit-exceeded tag-space step-limit]
      (let [step-limit (dec step-limit)]
        (if (not (seq? expression))
          [(get constants expression expression) tag-space step-limit]
          (if (= 1 (count expression))
            (if (map? (first expression))
              (eval-with-tagging
                (closest-association (:tagged (first expression)) tag-space default-value)
                tag-space step-limit constants default-value)
              [((resolve (first expression))) tag-space step-limit])
            (if (map? (first expression))
              (if (:tag (first expression))
                (if tagdo-semantics
                  (eval-with-tagging (second expression)
                                     (assoc tag-space (:tag (first expression)) (second expression))
                                     step-limit
                                     constants
                                     default-value)
                  [default-value 
                   (assoc tag-space (:tag (first expression)) (second expression)) 
                   step-limit])
                ;; must be tagged-with-arg
                (eval-with-tagging
                  (closest-association (:tagged-with-arg (first expression)) tag-space default-value)
                  (assoc tag-space (:arg (first expression)) (second expression))
                  step-limit constants default-value))
              (if (= 'if (first expression))
                (let [condition-eval-result 
                      (eval-with-tagging (second expression) tag-space step-limit constants default-value)]
                  (if (first condition-eval-result)
                    (eval-with-tagging (nth expression 2) 
                                       (nth condition-eval-result 1)
                                       (nth condition-eval-result 2)
                                       constants
                                       default-value)
                    (eval-with-tagging (nth expression 3) 
                                       (nth condition-eval-result 1)
                                       (nth condition-eval-result 2)
                                       constants
                                       default-value)))
                (let [arg-evaluation-results 
                      (loop [remaining (rest expression)
                             ts tag-space
                             lim step-limit
                             results []]
                        (if (empty? remaining)
                          results
                          (if (<= lim 0)
                            (recur (rest remaining) ts lim (conj results [:limit-exceeded ts lim]))
                            (let [first-result (eval-with-tagging 
                                                 (first remaining) ts lim constants default-value)]
                              (recur (rest remaining)
                                     (nth first-result 1)
                                     (nth first-result 2)
                                     (conj results first-result))))))
                      vals (map first arg-evaluation-results)
                      ending-limit (nth (last arg-evaluation-results) 2)
                      ending-ts (nth (last arg-evaluation-results) 1)]
                  (if (<= ending-limit 0)
                    [:limit-exceeded ending-ts ending-limit]
                    [(apply (resolve (first expression)) vals) ending-ts ending-limit]))))))))))
  
  
  
;; some examples
;
(eval-with-tagging '(+ 1 2) 100 {} 0)

(eval-with-tagging '(+ 1 (* x 2)) 100 {'x 10} 0)

(eval-with-tagging '(+ 1 (* x 2)) 3 {'x 10} 0)

(eval-with-tagging '(+ ({:tagged 123}) (* x 2)) 100 {'x 10} 0)

(eval-with-tagging '(+ ({:tagged 123}) (* x 2)) 100 {'x 10} 5)

(eval-with-tagging '(+ (+ ({:tag 123} (* 100 x)) ({:tagged 456}))
                       (* x ({:tagged 789})))
                   100 {'x 10} 0)

;; loops until the limit
(eval-with-tagging '(+ (+ ({:tag 123} ({:tagged 456})) ({:tagged 456}))
                       (* x ({:tagged 789})))
                   100 {'x 10} 0)

(eval-with-tagging '(+ (+ ({:tag 10} 1) ({:tag 20} 2)) (/ ({:tagged 5}) ({:tagged 15})))
                   100 {} 0)

(eval-with-tagging '(+ (+ ({:tag 10} 1) ({:tag 20} 2)) (/ ({:tagged 5}) ({:tagged 25})))
                   100 {} 0)

(eval-with-tagging '(if true (println :foo) (println :bar)) 100 {} false)

;(eval-with-tagging '(if (not true) (println :foo) (println :bar)) 100 {} false)

;; see the internals by calling with an empty tagspace arg

(eval-with-tagging 23 {} 100 {'x 10} 0)

(eval-with-tagging '(+ 1 1) {} 100 {'x 10} 0)

(eval-with-tagging '(+ 1 (* x 2)) {} 100 {'x 10} 0)

(eval-with-tagging '(+ ({:tagged 123}) (* x 2)) {} 100 {'x 10} 0)

(eval-with-tagging '({:tagged 123}) {} 100 {} 0)

(eval-with-tagging '({:tag 123} 99) {} 100 {} 0)

(eval-with-tagging '(+ ({:tag 123} 99) ({:tagged 123})) {} 100 {} 0)

(eval-with-tagging '(+ (+ ({:tag 123} (* 100 x)) ({:tagged 456}))
                       (* x ({:tagged 789})))
                   {} 100 {'x 10} 0)

;; here's an example with an argument:

(eval-with-tagging '(+ ({:tag 500} 1)
                       (+ ({:tag 123} (* 5 ({:tagged 456})))
                          (+ ({:tagged-with-arg 100 :arg 500} 10)
                             ({:tagged-with-arg 100 :arg 500} 100))))
                   100 {} 0)