<commit_before>(define empty-env '())

;; parser

;; see Barliman/interpreter_experiments/parse.scm and
;; Barliman/interpreter_experiments/parse-tests.scm
;; for more on the parser.
(define (parseo expr)
  (parse-expo expr parse-initial-env))

(define (parse-expo expr env)
  (conde
    ((fresh (val)
       (== `(quote ,val) expr)
       (absento 'closure val)
       (absento 'prim val)
       (parse-not-in-envo 'quote env)))

    ((numbero expr))

    ((symbolo expr)
     (fresh (val)
       ;;
       (conde
         ((keywordo expr)
          ;; if expr is a keyword ('lambda', 'begin', 'define', 'letrec', 'and', 'or', 'if', 'match', or whatever)
          ;; *and* expr is shadowed in the environment, succeed.  Otherwise, it is a syntax violation.
          (fresh (val)
            (lookupo expr env val)))
         ((not-keywordo expr)
          ;; Otherwise, succeed, since it doesn't matter if the symbol
          ;; is bound or not -- the expression is still grammatically
          ;; correct.
          ))))

    ((fresh (x body)
       (== `(lambda ,x ,body) expr)
       (parse-not-in-envo 'lambda env)
       (conde
         ;; Variadic
         ((symbolo x)
          (fresh (val env^)
            (== `((val . (,x . ,val)) . ,env) env^)
            (parse-expo body env^)))
         ;; Multi-argument
         ((list-of-symbolso x)
          (fresh (vals env^)
            (parse-ext-env*o x vals env env^)
            (parse-expo body env^))))))

    ((fresh (defn*/body)
       ;; 'begin' supporting multiple, mutually-recursive definitions
       (== `(begin . ,defn*/body) expr)
       (parse-not-in-envo 'begin env)
       (parse-begino defn*/body env)))

    ((fresh (rator rands)
       (== `(,rator . ,rands) expr)
       ;; application
       (parse-listo `(,rator . ,rands) env)))

    ((parse-matcho expr env))

    ((fresh (binding* letrec-body)
       ;; multiple-function letrec
       (== `(letrec ,binding* ,letrec-body) expr)
       (parse-not-in-envo 'letrec env)
       (parse-letreco binding* letrec-body env)))

    ((prim-parseo expr env))

    ))

(define (parse-begino defn*/body env)
  ;; parse (begin (define name (lambda args e)) ... body)
  ;; as    (letrec ((name (lambda args e)) ...) body)
  (letrec ((parse-begin
            (lambda (defn*/body env letrec-bindings)
              (conde
                ((fresh (body)
                   (== `(,body) defn*/body)
                   (parse-expo `(letrec ,letrec-bindings ,body) env)))
                ((fresh (name args e rest letrec-bindings^)
                   (== `((define ,name (lambda ,args ,e)) . ,rest) defn*/body)
                   (== `((,name (lambda ,args ,e)) . ,letrec-bindings) letrec-bindings^)
                   (parse-begin rest env letrec-bindings^)))))))
    (parse-begin defn*/body env '())))

(define (parse-letreco binding* letrec-body env)
  (letrec ((parse-letreco
            (lambda (binding* letrec-body env env-binding*)
              (conde
                ((== '() binding*)
                 (fresh (env^)
                   (== `((letrec . ,env-binding*) . ,env) env^)
                   (parse-letrec-lambda*o env-binding* env^)
                   (parse-expo letrec-body env^)))
                ((fresh (p-name x body rest)
                   (== `((,p-name (lambda ,x ,body)) . ,rest) binding*)
                   (symbolo p-name)
                   (parse-letreco rest letrec-body env `((rec . (,p-name . (lambda ,x ,body))) . ,env-binding*))))))))
    (parse-letreco binding* letrec-body env '())))

(define (parse-letrec-lambda*o env-binding* env^)
  (conde
    ((== '() env-binding*))
    ((fresh (p-name x body rest)
       (== `((rec . (,p-name . (lambda ,x ,body))) . ,rest) env-binding*)
       (parse-expo `(lambda ,x ,body) env^)
       (parse-letrec-lambda*o rest env^)))))

(define (parse-listo expr env)
  (conde
    ((== '() expr))
    ((fresh (a d)
       (== `(,a . ,d) expr)
       (parse-expo a env)
       (parse-listo d env)))))

(define (prim-parseo expr env)
  (conde
    ((boolean-parseo expr env))
    ((and-parseo expr env))
    ((or-parseo expr env))
    ((if-parseo expr env))
    ((cond-parseo expr env))))

(define (boolean-parseo expr env)
  (conde
    ((== #t expr))
    ((== #f expr))))

(define (and-parseo expr env)
  (fresh (e*)
    (== `(and . ,e*) expr)
    (parse-not-in-envo 'and env)
    (parse-listo e* env)))

(define (or-parseo expr env)
  (fresh (e*)
    (== `(or . ,e*) expr)
    (parse-not-in-envo 'or env)
    (parse-listo e* env)))

(define (if-parseo expr env)
  (fresh (e1 e2 e3)
    (== `(if ,e1 ,e2 ,e3) expr)
    (parse-not-in-envo 'if env)
    (parse-expo e1 env)
    (parse-expo e2 env)
    (parse-expo e3 env)))

(define (cond-parseo expr env)
  (fresh (c c*)
    (== `(cond ,c . ,c*) expr)
    (parse-not-in-envo 'cond env)
    (parse-cond-clauses `(,c . ,c*) env)))

(define (parse-cond-clauses c* env)
  (conde
    ((fresh (test conseq)
       (== `((,test ,conseq)) c*)
       (conde
         ((== 'else test))
         ((=/= 'else test)
          (parse-expo test env)))
       (parse-expo conseq env)))
    ((fresh (test conseq c*-rest)
       (== `((,test ,conseq) . ,c*-rest) c*)
       ;; ensure expressions like (cond (else 5) (6 7))
       ;; don't parse, unless 'else' has been shadowed
       (conde
         ((== 'else test)
          (fresh (v) (lookupo test env v)))
         ((=/= 'else test)
          (parse-expo test env)))
       (parse-expo conseq env)
       (parse-cond-clauses c*-rest env)))))

(define keywordo
  (lambda (x)
    (conde
      ((== 'quote x))
      ((== 'lambda x))
      ((== 'begin x))
      ((== 'define x))
      ((== 'letrec x))
      ((== 'and x))
      ((== 'or x))
      ((== 'if x))
      ((== 'conde x))
      ((== 'match x))
      ((== 'quasiquote x))
      ((== 'unquote x)))))

(define not-keywordo
  (lambda (x)
    (fresh ()
      (symbolo x)
      (=/= 'quote x)
      (=/= 'lambda x)
      (=/= 'begin x)
      (=/= 'define x)
      (=/= 'letrec x)
      (=/= 'and x)
      (=/= 'or x)
      (=/= 'if x)
      (=/= 'conde x)
      (=/= 'match x)
      (=/= 'quasiquote x)
      (=/= 'unquote x))))


;;; handle 'match'

(define parse-matcho
  (lambda  (expr env)
    (fresh (against-expr clause clauses)
      (== `(match ,against-expr ,clause . ,clauses) expr)
      (parse-not-in-envo 'match env)
      (parse-expo against-expr env)
      (parse-clauses `(,clause . ,clauses) env))))

(define (parse-clauses clauses env)
  (conde
    ((== '() clauses))
    ((fresh (pat result-expr d)
       (== `((,pat ,result-expr) . ,d) clauses)
       (fresh (penv env^)
         (parse-pattern pat '() penv)
         (parse-regular-env-appendo penv env env^)
         (parse-expo result-expr env^))
       (parse-clauses d env)))))

(define (parse-pattern pat penv penv-out)
  (conde
    ((self-eval-literalo pat)
     (== penv penv-out))
    ((parse-var-pat-match pat penv penv-out))
    ((fresh (var pred)
      (== `(? ,pred ,var) pat)
      (conde
        ((== 'symbol? pred))
        ((== 'number? pred)))
      (parse-var-pat-match var penv penv-out)))
    ((fresh (quasi-pat)
      (== (list 'quasiquote quasi-pat) pat)
      (parse-quasiquote-pattern quasi-pat penv penv-out)))))

(define (parse-var-pat-match var penv penv-out)
  (fresh (_)
    (symbolo var)
    (conde
      ((== penv penv-out)
       (parse-lookupo var penv _))
      ((== `((val . (,var . ,_)) . ,penv) penv-out)
       (parse-not-in-envo var penv)))))

(define (parse-quasiquote-pattern quasi-pat penv penv-out)
  (conde
    ((== penv penv-out)
     (literalo quasi-pat))
    ((fresh (pat)
      (== (list 'unquote pat) quasi-pat)
      (parse-pattern pat penv penv-out)))
    ((fresh (a d penv^)
       (== `(,a . ,d) quasi-pat)
       (=/= 'unquote a)
       (parse-quasiquote-pattern a penv penv^)
       (parse-quasiquote-pattern d penv^ penv-out)))))


;;; parse-specific helpers
(define (parse-not-in-envo x env)
  (conde
    ((== empty-env env))
    ((fresh (y b rest)
       (== `((val . (,y . ,b)) . ,rest) env)
       (=/= x y)
       (parse-not-in-envo x rest)))
    ((fresh (env-binding* rest)
       (== `((letrec . ,env-binding*) . ,rest) env)
       (parse-not-in-letrec-envo x env-binding* rest)))))

(define (parse-not-in-letrec-envo x env-binding* rest)
  (conde
    ((== '() env-binding*)
     (parse-not-in-envo x rest))
    ((fresh (p-name lam-expr env-binding-rest)
       (== `((rec . (,p-name . ,lam-expr)) . ,env-binding-rest) env-binding*)
       (=/= p-name x)
       (parse-not-in-letrec-envo x env-binding-rest rest)))))

(define (parse-ext-env*o x* a* env out)
  (conde
    ((== '() x*) (== '() a*) (== env out))
    ((fresh (x a dx* da* env2)
       (== `(,x . ,dx*) x*)
       (== `(,a . ,da*) a*)
       (== `((val . (,x . ,a)) . ,env) env2)
       (symbolo x)
       (parse-ext-env*o dx* da* env2 out)))))

(define (parse-regular-env-appendo env1 env2 env-out)
  (conde
    ((== empty-env env1) (== env2 env-out))
    ((fresh (y v rest res)
       (== `((val . (,y . ,v)) . ,rest) env1)
       (== `((val . (,y . ,v)) . ,res) env-out)
       (parse-regular-env-appendo rest env2 res)))))

(define (parse-lookupo x env v)
  (conde
    ((fresh (y b rest)
       (== `((val . (,y . ,b)) . ,rest) env)
       (conde
         ((== x y) (== b v))
         ((=/= x y) (parse-lookupo x rest v)))))
    ((fresh (env-binding* rest)
       (== `((letrec . ,env-binding*) . ,rest) env)
       (parse-lookup-in-letrec-envo x env-binding* rest env v)))))

(define (parse-lookup-in-letrec-envo x env-binding* rest env v)
  (conde
    ((== '() env-binding*)
     (parse-lookupo x rest v))
    ((fresh (p-name lam-expr env-binding-rest)
       (== `((rec . (,p-name . ,lam-expr)) . ,env-binding-rest) env-binding*)
       (conde
         ((== p-name x)
          (== `(closure ,lam-expr ,env) v))
         ((=/= p-name x)
          (parse-lookup-in-letrec-envo x env-binding-rest rest env v)))))))

(define parse-initial-env `((val . (car . (prim . car)))
                            (val . (cdr . (prim . cdr)))
                            (val . (null? . (prim . null?)))
                            (val . (pair? . (prim . pair?)))
                            (val . (symbol? . (prim . symbol?)))
                            (val . (cons . (prim . cons)))
                            (val . (not . (prim . not)))
                            (val . (equal? . (prim . equal?)))
                            (val . (list . (closure (lambda x x) ,empty-env)))
                            . ,empty-env))








;;; interpreter
(define (evalo expr val)
  (eval-expo expr initial-env val))

(define (eval-expo expr env val)
  (try-lookup-before expr env val (eval-expo-rest expr env val)))

(define (eval-expo-rest expr env val)
  (lambdag@ (st)
    (let* ((expr (walk expr (state-S st)))
           (env (walk env (state-S st)))
           (depth (state-depth st))
           (goal (lambdag@ (st)
                   ((conde
    ((numbero expr) (== expr val))
    ((fresh (rator x* rands a* prim-id)
       (== `(,rator . ,rands) expr)
       (eval-expo rator env `(prim . ,prim-id))
       (eval-primo prim-id a* val rands env)))

    ((fresh (rator x* rands body env^ a* res)
       (== `(,rator . ,rands) expr)
       ;; Multi-argument
       (eval-expo rator env `(closure (lambda ,x* ,body) ,env^))
       (ext-env*o x* a* env^ res)
       ; replacing eval-application with these may be faster with multi-level defer
       ;(eval-expo body res val)
       ;(eval-listo rands env a*)
       (eval-application rands env a* (eval-expo body res val))
       ))

    ((if-primo expr env val))

    ((cond-primo expr env val))

    ((fresh (rator x rands body env^ a* res)
       (== `(,rator . ,rands) expr)
       ;; variadic
       (symbolo x)
       (== `((,x . (val . ,a*)) . ,env^) res)
       (eval-expo rator env `(closure (lambda ,x ,body) ,env^))
       (eval-expo body res val)
       (eval-listo rands env a*)))

    ((== `(quote ,val) expr)
     (absento 'closure val)
     (absento 'prim val)
     (not-in-envo 'quote env))

    ((fresh (x body)
       (== `(lambda ,x ,body) expr)
       (== `(closure (lambda ,x ,body) ,env) val)
       (conde$
         ;; Variadic
         ((symbolo x))
         ;; Multi-argument
         ((list-of-symbolso x)))
       (not-in-envo 'lambda env)))

    ;; WEB 25 May 2016 -- This rather budget version of 'begin' is
    ;; useful for separating 'define' from the expression 'e',
    ;; specifically for purposes of Barliman.
    ((fresh (defn args name body e)
       (== `(begin ,defn ,e) expr)
       (== `(define ,name (lambda ,args ,body)) defn)
       (eval-expo `(letrec ((,name (lambda ,args ,body))) ,e) env val)))

    ((handle-matcho expr env val))

    ((fresh (p-name x body letrec-body)
       ;; single-function variadic letrec version
       (== `(letrec ((,p-name (lambda ,x ,body)))
              ,letrec-body)
           expr)
       (conde$
         ; Variadic
         ((symbolo x))
         ; Multiple argument
         ((list-of-symbolso x)))
       (not-in-envo 'letrec env)
       (eval-expo letrec-body
                  `((,p-name . (rec . (lambda ,x ,body))) . ,env)
                  val)))

    ((prim-expo expr env val)))
                    (state-depth-set st depth)))))

      (if (or (var? expr)
              (var? env)
              (and (pair? expr) (var? (walk (car expr) (state-S st)))))
        (state-deferred-defer st goal)
        (goal st)))))
<commit_msg>Factor out paramso<commit_after>(define empty-env '())

;; parser

;; see Barliman/interpreter_experiments/parse.scm and
;; Barliman/interpreter_experiments/parse-tests.scm
;; for more on the parser.
(define (parseo expr)
  (parse-expo expr parse-initial-env))

(define (parse-expo expr env)
  (conde
    ((fresh (val)
       (== `(quote ,val) expr)
       (absento 'closure val)
       (absento 'prim val)
       (parse-not-in-envo 'quote env)))

    ((numbero expr))

    ((symbolo expr)
     (fresh (val)
       ;;
       (conde
         ((keywordo expr)
          ;; if expr is a keyword ('lambda', 'begin', 'define', 'letrec', 'and', 'or', 'if', 'match', or whatever)
          ;; *and* expr is shadowed in the environment, succeed.  Otherwise, it is a syntax violation.
          (fresh (val)
            (lookupo expr env val)))
         ((not-keywordo expr)
          ;; Otherwise, succeed, since it doesn't matter if the symbol
          ;; is bound or not -- the expression is still grammatically
          ;; correct.
          ))))

    ((fresh (x body)
       (== `(lambda ,x ,body) expr)
       (parse-not-in-envo 'lambda env)
       (conde
         ;; Variadic
         ((symbolo x)
          (fresh (val env^)
            (== `((val . (,x . ,val)) . ,env) env^)
            (parse-expo body env^)))
         ;; Multi-argument
         ((list-of-symbolso x)
          (fresh (vals env^)
            (parse-ext-env*o x vals env env^)
            (parse-expo body env^))))))

    ((fresh (defn*/body)
       ;; 'begin' supporting multiple, mutually-recursive definitions
       (== `(begin . ,defn*/body) expr)
       (parse-not-in-envo 'begin env)
       (parse-begino defn*/body env)))

    ((fresh (rator rands)
       (== `(,rator . ,rands) expr)
       ;; application
       (parse-listo `(,rator . ,rands) env)))

    ((parse-matcho expr env))

    ((fresh (binding* letrec-body)
       ;; multiple-function letrec
       (== `(letrec ,binding* ,letrec-body) expr)
       (parse-not-in-envo 'letrec env)
       (parse-letreco binding* letrec-body env)))

    ((prim-parseo expr env))

    ))

(define (parse-begino defn*/body env)
  ;; parse (begin (define name (lambda args e)) ... body)
  ;; as    (letrec ((name (lambda args e)) ...) body)
  (letrec ((parse-begin
            (lambda (defn*/body env letrec-bindings)
              (conde
                ((fresh (body)
                   (== `(,body) defn*/body)
                   (parse-expo `(letrec ,letrec-bindings ,body) env)))
                ((fresh (name args e rest letrec-bindings^)
                   (== `((define ,name (lambda ,args ,e)) . ,rest) defn*/body)
                   (== `((,name (lambda ,args ,e)) . ,letrec-bindings) letrec-bindings^)
                   (parse-begin rest env letrec-bindings^)))))))
    (parse-begin defn*/body env '())))

(define (parse-letreco binding* letrec-body env)
  (letrec ((parse-letreco
            (lambda (binding* letrec-body env env-binding*)
              (conde
                ((== '() binding*)
                 (fresh (env^)
                   (== `((letrec . ,env-binding*) . ,env) env^)
                   (parse-letrec-lambda*o env-binding* env^)
                   (parse-expo letrec-body env^)))
                ((fresh (p-name x body rest)
                   (== `((,p-name (lambda ,x ,body)) . ,rest) binding*)
                   (symbolo p-name)
                   (parse-letreco rest letrec-body env `((rec . (,p-name . (lambda ,x ,body))) . ,env-binding*))))))))
    (parse-letreco binding* letrec-body env '())))

(define (parse-letrec-lambda*o env-binding* env^)
  (conde
    ((== '() env-binding*))
    ((fresh (p-name x body rest)
       (== `((rec . (,p-name . (lambda ,x ,body))) . ,rest) env-binding*)
       (parse-expo `(lambda ,x ,body) env^)
       (parse-letrec-lambda*o rest env^)))))

(define (parse-listo expr env)
  (conde
    ((== '() expr))
    ((fresh (a d)
       (== `(,a . ,d) expr)
       (parse-expo a env)
       (parse-listo d env)))))

(define (prim-parseo expr env)
  (conde
    ((boolean-parseo expr env))
    ((and-parseo expr env))
    ((or-parseo expr env))
    ((if-parseo expr env))
    ((cond-parseo expr env))))

(define (boolean-parseo expr env)
  (conde
    ((== #t expr))
    ((== #f expr))))

(define (and-parseo expr env)
  (fresh (e*)
    (== `(and . ,e*) expr)
    (parse-not-in-envo 'and env)
    (parse-listo e* env)))

(define (or-parseo expr env)
  (fresh (e*)
    (== `(or . ,e*) expr)
    (parse-not-in-envo 'or env)
    (parse-listo e* env)))

(define (if-parseo expr env)
  (fresh (e1 e2 e3)
    (== `(if ,e1 ,e2 ,e3) expr)
    (parse-not-in-envo 'if env)
    (parse-expo e1 env)
    (parse-expo e2 env)
    (parse-expo e3 env)))

(define (cond-parseo expr env)
  (fresh (c c*)
    (== `(cond ,c . ,c*) expr)
    (parse-not-in-envo 'cond env)
    (parse-cond-clauses `(,c . ,c*) env)))

(define (parse-cond-clauses c* env)
  (conde
    ((fresh (test conseq)
       (== `((,test ,conseq)) c*)
       (conde
         ((== 'else test))
         ((=/= 'else test)
          (parse-expo test env)))
       (parse-expo conseq env)))
    ((fresh (test conseq c*-rest)
       (== `((,test ,conseq) . ,c*-rest) c*)
       ;; ensure expressions like (cond (else 5) (6 7))
       ;; don't parse, unless 'else' has been shadowed
       (conde
         ((== 'else test)
          (fresh (v) (lookupo test env v)))
         ((=/= 'else test)
          (parse-expo test env)))
       (parse-expo conseq env)
       (parse-cond-clauses c*-rest env)))))

(define keywordo
  (lambda (x)
    (conde
      ((== 'quote x))
      ((== 'lambda x))
      ((== 'begin x))
      ((== 'define x))
      ((== 'letrec x))
      ((== 'and x))
      ((== 'or x))
      ((== 'if x))
      ((== 'conde x))
      ((== 'match x))
      ((== 'quasiquote x))
      ((== 'unquote x)))))

(define not-keywordo
  (lambda (x)
    (fresh ()
      (symbolo x)
      (=/= 'quote x)
      (=/= 'lambda x)
      (=/= 'begin x)
      (=/= 'define x)
      (=/= 'letrec x)
      (=/= 'and x)
      (=/= 'or x)
      (=/= 'if x)
      (=/= 'conde x)
      (=/= 'match x)
      (=/= 'quasiquote x)
      (=/= 'unquote x))))


;;; handle 'match'

(define parse-matcho
  (lambda  (expr env)
    (fresh (against-expr clause clauses)
      (== `(match ,against-expr ,clause . ,clauses) expr)
      (parse-not-in-envo 'match env)
      (parse-expo against-expr env)
      (parse-clauses `(,clause . ,clauses) env))))

(define (parse-clauses clauses env)
  (conde
    ((== '() clauses))
    ((fresh (pat result-expr d)
       (== `((,pat ,result-expr) . ,d) clauses)
       (fresh (penv env^)
         (parse-pattern pat '() penv)
         (parse-regular-env-appendo penv env env^)
         (parse-expo result-expr env^))
       (parse-clauses d env)))))

(define (parse-pattern pat penv penv-out)
  (conde
    ((self-eval-literalo pat)
     (== penv penv-out))
    ((parse-var-pat-match pat penv penv-out))
    ((fresh (var pred)
      (== `(? ,pred ,var) pat)
      (conde
        ((== 'symbol? pred))
        ((== 'number? pred)))
      (parse-var-pat-match var penv penv-out)))
    ((fresh (quasi-pat)
      (== (list 'quasiquote quasi-pat) pat)
      (parse-quasiquote-pattern quasi-pat penv penv-out)))))

(define (parse-var-pat-match var penv penv-out)
  (fresh (_)
    (symbolo var)
    (conde
      ((== penv penv-out)
       (parse-lookupo var penv _))
      ((== `((val . (,var . ,_)) . ,penv) penv-out)
       (parse-not-in-envo var penv)))))

(define (parse-quasiquote-pattern quasi-pat penv penv-out)
  (conde
    ((== penv penv-out)
     (literalo quasi-pat))
    ((fresh (pat)
      (== (list 'unquote pat) quasi-pat)
      (parse-pattern pat penv penv-out)))
    ((fresh (a d penv^)
       (== `(,a . ,d) quasi-pat)
       (=/= 'unquote a)
       (parse-quasiquote-pattern a penv penv^)
       (parse-quasiquote-pattern d penv^ penv-out)))))


;;; parse-specific helpers
(define (parse-not-in-envo x env)
  (conde
    ((== empty-env env))
    ((fresh (y b rest)
       (== `((val . (,y . ,b)) . ,rest) env)
       (=/= x y)
       (parse-not-in-envo x rest)))
    ((fresh (env-binding* rest)
       (== `((letrec . ,env-binding*) . ,rest) env)
       (parse-not-in-letrec-envo x env-binding* rest)))))

(define (parse-not-in-letrec-envo x env-binding* rest)
  (conde
    ((== '() env-binding*)
     (parse-not-in-envo x rest))
    ((fresh (p-name lam-expr env-binding-rest)
       (== `((rec . (,p-name . ,lam-expr)) . ,env-binding-rest) env-binding*)
       (=/= p-name x)
       (parse-not-in-letrec-envo x env-binding-rest rest)))))

(define (parse-ext-env*o x* a* env out)
  (conde
    ((== '() x*) (== '() a*) (== env out))
    ((fresh (x a dx* da* env2)
       (== `(,x . ,dx*) x*)
       (== `(,a . ,da*) a*)
       (== `((val . (,x . ,a)) . ,env) env2)
       (symbolo x)
       (parse-ext-env*o dx* da* env2 out)))))

(define (parse-regular-env-appendo env1 env2 env-out)
  (conde
    ((== empty-env env1) (== env2 env-out))
    ((fresh (y v rest res)
       (== `((val . (,y . ,v)) . ,rest) env1)
       (== `((val . (,y . ,v)) . ,res) env-out)
       (parse-regular-env-appendo rest env2 res)))))

(define (parse-lookupo x env v)
  (conde
    ((fresh (y b rest)
       (== `((val . (,y . ,b)) . ,rest) env)
       (conde
         ((== x y) (== b v))
         ((=/= x y) (parse-lookupo x rest v)))))
    ((fresh (env-binding* rest)
       (== `((letrec . ,env-binding*) . ,rest) env)
       (parse-lookup-in-letrec-envo x env-binding* rest env v)))))

(define (parse-lookup-in-letrec-envo x env-binding* rest env v)
  (conde
    ((== '() env-binding*)
     (parse-lookupo x rest v))
    ((fresh (p-name lam-expr env-binding-rest)
       (== `((rec . (,p-name . ,lam-expr)) . ,env-binding-rest) env-binding*)
       (conde
         ((== p-name x)
          (== `(closure ,lam-expr ,env) v))
         ((=/= p-name x)
          (parse-lookup-in-letrec-envo x env-binding-rest rest env v)))))))

(define parse-initial-env `((val . (car . (prim . car)))
                            (val . (cdr . (prim . cdr)))
                            (val . (null? . (prim . null?)))
                            (val . (pair? . (prim . pair?)))
                            (val . (symbol? . (prim . symbol?)))
                            (val . (cons . (prim . cons)))
                            (val . (not . (prim . not)))
                            (val . (equal? . (prim . equal?)))
                            (val . (list . (closure (lambda x x) ,empty-env)))
                            . ,empty-env))








;;; interpreter
(define (evalo expr val)
  (eval-expo expr initial-env val))

(define (eval-expo expr env val)
  (try-lookup-before expr env val (eval-expo-rest expr env val)))

(define (paramso params)
  (conde$-dfs
    ; Multiple argument
    ((list-of-symbolso params))
    ; Variadic
    ((symbolo params))))

(define (eval-expo-rest expr env val)
  (lambdag@ (st)
    (let* ((expr (walk expr (state-S st)))
           (env (walk env (state-S st)))
           (depth (state-depth st))
           (goal (lambdag@ (st)
                   ((conde
    ((numbero expr) (== expr val))
    ((fresh (rator x* rands a* prim-id)
       (== `(,rator . ,rands) expr)
       (eval-expo rator env `(prim . ,prim-id))
       (eval-primo prim-id a* val rands env)))

    ((fresh (rator x* rands body env^ a* res)
       (== `(,rator . ,rands) expr)
       ;; Multi-argument
       (eval-expo rator env `(closure (lambda ,x* ,body) ,env^))
       (ext-env*o x* a* env^ res)
       ; replacing eval-application with these may be faster with multi-level defer
       ;(eval-expo body res val)
       ;(eval-listo rands env a*)
       (eval-application rands env a* (eval-expo body res val))
       ))

    ((if-primo expr env val))

    ((cond-primo expr env val))

    ((fresh (rator x rands body env^ a* res)
       (== `(,rator . ,rands) expr)
       ;; variadic
       (symbolo x)
       (== `((,x . (val . ,a*)) . ,env^) res)
       (eval-expo rator env `(closure (lambda ,x ,body) ,env^))
       (eval-expo body res val)
       (eval-listo rands env a*)))

    ((== `(quote ,val) expr)
     (absento 'closure val)
     (absento 'prim val)
     (not-in-envo 'quote env))

    ((fresh (x body)
       (== `(lambda ,x ,body) expr)
       (== `(closure (lambda ,x ,body) ,env) val)
       (paramso x)
       (not-in-envo 'lambda env)))

    ;; WEB 25 May 2016 -- This rather budget version of 'begin' is
    ;; useful for separating 'define' from the expression 'e',
    ;; specifically for purposes of Barliman.
    ((fresh (defn args name body e)
       (== `(begin ,defn ,e) expr)
       (== `(define ,name (lambda ,args ,body)) defn)
       (eval-expo `(letrec ((,name (lambda ,args ,body))) ,e) env val)))

    ((handle-matcho expr env val))

    ((fresh (p-name x body letrec-body)
       ;; single-function variadic letrec version
       (== `(letrec ((,p-name (lambda ,x ,body)))
              ,letrec-body)
           expr)
       (paramso x)
       (not-in-envo 'letrec env)
       (eval-expo letrec-body
                  `((,p-name . (rec . (lambda ,x ,body))) . ,env)
                  val)))

    ((prim-expo expr env val)))
                    (state-depth-set st depth)))))

      (if (or (var? expr)
              (var? env)
              (and (pair? expr) (var? (walk (car expr) (state-S st)))))
        (state-deferred-defer st goal)
        (goal st)))))

{'fraction_non_alphanumeric': 0.1918362798989749, 'fraction_numerical': 0.002005645520725004, 'mean_word_length': 1.9196486662329213, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 3, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '813676', 'n_tokens_mistral': 9860, 'n_tokens_neox': 9517, 'n_words': 2572}