dyn-fexpr-eval.rkt

#lang racket/gui

(require srfi/1)

;;; ENVIRONMENT

(struct environ (dyn caps top props))

(define (make-empty-env)
  (environ (make-immutable-hasheq) (make-immutable-hasheq) (make-hasheq) (make-weak-hasheq)))

(define (environ->string env)
  (match env
    ((environ dyn caps top props)
     (format "#<environ ~A ~A ~A ~A>"
             (hash->string dyn)
             (hash->string caps)
             (hash->string top)
             (hash->string props)))))

(define-syntax env-copy
  (syntax-rules ()
    ((_ expr xs ...)
     (struct-copy environ expr xs ...))))

;;; HASH TABLE

(define (hash->string tb)
  (let ((res "#<hash"))
    (hash-map
     tb
     (lambda (k v)
       (set! res (format "~A (~A . ~A)" res k v))))
    (format "~A>" res)))

(define (hash-ref-then-else ht var then else)
  (let* ((bad (cons 1 1))
         (res (hash-ref ht var bad)))
    (if (eq? res bad)
        (else ht var)
        (then res))))

(define (hash-ref-else ht var else)
  (hash-ref-then-else ht var (lambda (x) x) else))

(define (hash-overwrite ht lst)
  (match lst
    ('() ht)
    (`((,k . ,x) . ,lst) (hash-overwrite (hash-set ht k x) lst))))

(define (hash-remove-all ht lst)
  (match lst
    ('() ht)
    (`(,k . ,lst) (hash-remove-all (hash-remove ht k) lst))))

;;; DISPLAY FORMAT

(define (displayf fmt . xs)
  (display (apply format fmt xs)))

;;; APPLY

(define (apply-access-var var env)
  (match env
    ((environ dyn _ top _)
     (hash-ref-else dyn var
       (lambda _
         (hash-ref-else top var
           (lambda _
             (error "No such variable:" var))))))))

(define (apply-ref-var var env)
  (unbox (apply-access-var var env)))

(define (apply-set-var var env val)
  (set-box! (apply-access-var var env) val))

;;; EVAL

(define (atom? x)
  (or (string? x) (number? x) (boolean? x) (null? x)))

(define (eval-seq body env)
  (let ((r (eval* (car body) env)))
    (if (null? (cdr body))
        r
        (eval-seq (cdr body) env))))

(define (eval expr (env (make-std-env)))
  (eval* (@ env @macroexpand-all expr) env))

(define (eval* expr env)
  ; (displayf "(eval* ~S) with ~A~%" expr (environ->string env))
  ; (displayf "(eval* ~S)~%" expr)
  (match expr
    ((? symbol? x) (apply-ref-var x env))
    ((? atom? x) x)
    (`(quote ,x) x)
    (`(lambda ,ars ,b ,@bs)
     #:when (and (or (symbol? ars) (list? ars))
                 (or (not (eq? b '#:fexpr)) (not (= 0 (length bs))) #t))
     (when (and (eq? b '#:fexpr)
                (= 0 (length bs)))
       (error 'eval "No body for lambda: ~A" expr))
     (define (collect-caps)
       (let ((caps (environ-caps env))
             (dyn (environ-dyn env))
             (r '()))
         (hash-map caps (lambda (k _) (set! r (cons (cons k (hash-ref dyn k)) r))))
         r))
     (let* ((whole-args? (symbol? ars))
            (ars (if whole-args? (list ars) ars))
            (caps (collect-caps))
            (new-caps (hash-remove-all (environ-caps env) ars)))
       (define (bind avs env)
         (let ((avs (if whole-args? (list avs) avs)))
           (define (cons-v-box x y)
             (cons x (box y)))
           (when (not (= (length ars) (length avs)))
             (error 'eval "argument arity mismatch, need ~A, but got ~A" (length ars) (length avs)))
           (env-copy env
             (dyn (hash-overwrite (environ-dyn env) (append caps (map cons-v-box ars avs))))
             (caps new-caps))))
       (if (eq? b '#:fexpr)
           (lambda (avs env)
             (eval-seq bs (bind avs env)))
           (lambda (avs env)
             (define (eval** expr) (eval* expr env))
             (eval-seq (cons b bs) (bind (map eval** avs) env))))))
    (`(closure (,@caps) ,b ,@bs)
     (define (build x) (list x #t))
     (eval-seq (cons b bs)
       (env-copy env
         (caps (hash-overwrite (environ-caps env) (map build caps))))))
    (`(if ,x ,y)
     (if (eval* x env) (eval* y env) #f))
    (`(if ,x ,y ,z)
     (if (eval* x env) (eval* y env) (eval* z env)))
    (`(set! ,x ,y)
     (apply-set-var x env (eval* y env)))
    (`(,f ,@rest)
     ((eval* f env) rest env))))

;;; FUNCTION

(define (& f)
  (lambda (avs env)
    (define (eval** expr) (eval* expr env))
    (apply f (map eval** avs))))

(define (@ env f . xs)
  (define (quote* val) (list 'quote val))
  (f (map quote* xs) env))

(define-syntax define*
  (syntax-rules ()
    ((_ (name xs ...) env b bs ...)
     (define name (lambda* (xs ...) env b bs ...)))))

(define-syntax lambda*
  (syntax-rules ()
    ((_ (xs ...) env b bs ...)
     (lambda (expr env)
       (define (eval** expr) (eval* expr env))
       (match (map eval** expr)
         (`(,xs ...) b bs ...))))))

(define* (@gensym) env
  (gensym))

(define* (@set-top! x y) env
  (when (not (symbol? x))
    (error 'set-top! "bad name ~A" x))
  (hash-ref-then-else (environ-top env) x
    (lambda (b) (set-box! b y))
    (lambda _ (hash-set! (environ-top env) x (box y)))))

;;; PROPERTIES

(define* (@putprop! x y v) env
  (hash-ref-then-else (environ-props env) x
    (lambda (tb)
      (hash-ref-then-else tb y
        (lambda (b)
          (set-box! b v))
        (lambda (tb y)
          (hash-set! tb y (box v)))))
    (lambda (tb x)
      (let ((sub (make-weak-hasheq)))
        (hash-set! tb x sub)
        (hash-set! sub y (box v)))))
  (void))

(define* (@getprop x y dft) env
  (hash-ref-then-else (environ-props env) x
    (lambda (tb)
      (hash-ref-then-else tb y
        (lambda (b)
          (unbox b))
        (lambda _ dft)))
    (lambda _ dft)))

(define* (@remprop! x y) env
  (hash-ref-then-else (environ-props env) x
    (lambda (tb)
      (hash-remove! tb y))
    (lambda _ (void))))

;;; MACRO

(define* (@macro? x) env
  (and (list? x) (pair? x) (@ env @getprop (car x) 'macro #f)))

(define* (@macro-function x) env
  (@ env @getprop x 'macro #f))

(define* (@install-macro! name f) env
  (@ env @putprop! name 'macro f))

(define* (@initial-expander x e menv) env
  ; (displayf "(expand ~S)~%" x)
  (let ((e1 (cond ((symbol? x)
                   (apply-ref-var '*identifier-expander* env))
                  ((not (list? x))
                   (lambda* (x e menv) env x))
                  ((@ env @macro? x)
                   (@ env @macro-function (car x)))
                  (else
                   (apply-ref-var '*application-expander* env)))))
    (@ env e1 x e menv)))

(define* (dft-id-expander x e menv) env x)
(define* (dft-app-expander x e menv) env
  (map (lambda (x) (@ env e x e menv)) x))

(define (@macroexpand-all expr env)
  (define (eval** x) (eval* x env))
  (match (map eval** expr)
    (`(,x)
     (@ env @initial-expander x @initial-expander (apply-ref-var '*macro-environment* env)))
    (`(,x ,menv)
     (@ env @initial-expander x @initial-expander menv))
    (`(,x ,menv ,e)
     (@ env e x e menv))))

(define (@macroexpand-1 expr env)
  (define (eval** x) (eval* x env))
  (match (map eval** expr)
    (`(,x)
     (@ env @initial-expander x (lambda* (x e menv) env x) (apply-ref-var '*macro-environment* env)))
    (`(,x ,menv)
     (@ env @initial-expander x (lambda* (x e menv) env x) menv))
    (`(,x ,menv ,e)
     (@ env e x (lambda* (x e menv) env x) menv))))

(define* (lambda-expander x e menv) env
  (match x
    (`(lambda ,ars ,b ,@bs)
     #:when (or (symbol? ars) (and (list? ars) (every symbol? ars)))
     (let ((bs (if (eq? b '#:fexpr) bs (cons b bs))))
       `(lambda ,ars
          ,@(map (lambda (x) (@ env e x e menv)) bs))))))

(define* (closure-expander x e menv) env
  (define (symbol-list? x) (and (list? x) (every symbol? x)))
  (match x
    (`(closure ,caps ,b ,@bs)
     #:when (and (symbol-list? caps) (list? bs))
     `(closure ,caps
        ,@(map (lambda (x) (@ env e x e menv)) (cons b bs))))))

(define* (quote-expander x e menv) env
  (match x (`(quote ,x) `(quote ,x))))

(define* (if-expander x e menv) env
  (match x
    (`(if ,x ,y)
     `(if ,(@ env e x e menv)
          ,(@ env e y e menv)))
    (`(if ,x ,y ,z)
     `(if ,(@ env e x e menv)
          ,(@ env e y e menv)
          ,(@ env e z e menv)))))

(define* (set!-expander x e menv) env
  (match x
    (`(set! ,x ,y)
     `(set! ,x ,(@ env e y e menv)))))

(define* (quasiquote-expander x e menv) env
  (unless (= 2 (length x))
    (error 'bad-quasiquote))
  (define (unquote-splicing? x)
    (and (list? x) (= 2 (length x)) (eq? 'unquote-splicing (car x))))
  (define (unquote? x)
    (and (list? x) (= 2 (length x)) (eq? 'unquote (car x))))
  (define (cons* x y)
    (if (and (pair? x) (pair? y) (eq? 'quote (car x)) (eq? 'quote (car y)))
        `(quote (,(cadr x) . ,(cadr y)))
        (list 'cons x y)))
  (define (expand x)
    (match x
      (`(,x . ,xs) #:when (unquote-splicing? x)
       (let ((vals (@ env e (cadr x) e menv)))
         (list 'append vals (expand xs))))
      (x #:when (unquote? x)
       (@ env e (cadr x) e menv))
      (`(,x . ,xs)
       (cons* (expand x) (expand xs)))
      (x
       (list 'quote x))))
  (expand (cadr x)))

(define (bind-form? x) (or (symbol? x) (and (list? x) (= 2 (length x)) (symbol? (car x)))))

(define* (let-expander x e menv) env
  (match x
    (`(let (,@bindings) ,b ,@bs)
     #:when (every bind-form? bindings)
     (let ((bindings (map (lambda (x) (if (symbol? x) (list x #f) x)) bindings)))
       (@ env e `((lambda ,(map car bindings) ,b ,@bs) ,@(map cadr bindings)) e menv)))))

(define* (let*-expander x e menv) env
  (match x
    (`(let* (,@bindings) ,b ,@bs)
     #:when (every bind-form? bindings)
     (cond ((null? bindings)
            (@ env e `(let () ,b ,@bs) e menv))
           ((null? (cdr bindings))
            (@ env e `(let ,bindings ,b ,@bs) e menv))
           (else
            (@ env e `(let (,(car bindings)) (let* ,(cdr bindings) ,b ,@bs)) e menv))))))

(define* (@make-macro pat body) env
  (define (destructure* pat arg bindings ctn)
    (match pat
      (`() (ctn bindings))
      ((? symbol? x) (ctn (cons (list x arg) bindings)))
      (`(,x . ,y)
       (let ((cararg `(,(gensym) (car ,arg)))
             (cdrarg `(,(gensym) (cdr ,arg))))
         (destructure* x (car cararg) (list* cararg cdrarg bindings)
           (lambda (bindings)
             (destructure* y (car cdrarg) bindings ctn)))))))
  (define (destructure pat arg)
    (destructure* pat arg '() (lambda (bindings) (reverse bindings))))
  (eval `(lambda (x e menv) (e (let* ,(destructure pat '(cdr x)) ,@body) e menv)) env))

(define* (defmacro-expander x e menv) env
  (match x
    (`(defmacro ,name ,pat ,b ,@bs)
     (@ env e `(install-macro! ',name (make-macro ',pat ',(cons b bs))) e menv))))

;;; STANDARD ENVIRONMENT

(define* (evaluator-eval expr) env
  (eval expr env))

(define* (evaluator-apply f expr) env
  (f expr env))

(define (make-std-env)
  (let ((env (make-empty-env)))
    (map
     (lambda (x) (match x ((list x y) (@ env @set-top! x y))))
     `(;; eval apply
       (eval ,evaluator-eval) (apply ,evaluator-apply)
       ;; toplevel
       (set-top! ,|@set-top!|) ; (eq 'abc '|abc|) => #t
       ;; arithmetic
       (+ ,(& +)) (- ,(& -)) (* ,(& *)) (/ ,(& /)) (remainder ,(& remainder)) (log ,(& log))
       ;; logical
       (> ,(& >)) (< ,(& <)) (>= ,(& >=)) (<= ,(& <=)) (= ,(& =)) (eq? ,(& eq?)) (eqv? ,(& eqv?)) (equal? ,(& equal?))
       ;; list
       (car ,(& car)) (cdr ,(& cdr)) (list ,(& list)) (cons ,(& cons)) (append ,(& append)) (null? ,(& null?))
       (list? ,(& list?)) (length ,(& length))
       ;; symbol
       (symbol? ,(& symbol?)) (gensym ,|@gensym|)
       ;; error
       (error ,(& error))
       ;; properties
       (getprop ,|@getprop|) (putprop! ,|@putprop!|) (remprop! ,|@remprop!|)
       ;; macro
       (install-macro! ,|@install-macro!|) (macroexpand-1 ,|@macroexpand-1|) (macroexpand-all ,|@macroexpand-all|)
       (*macro-environment* '()) (*identifier-expander* ,dft-id-expander) (*application-expander* ,dft-app-expander)
       (make-macro ,|@make-macro|) (initial-expander ,|@initial-expander|) (macro? ,|@macro?|)
       (macro-function ,|@macro-function|)
       ;; continuation
       (call/cc ,(& call/cc))
       ;; io
       (displayf ,(& displayf))))
    (@ env @install-macro! 'quasiquote quasiquote-expander)
    (map
     (lambda (x) (match x ((list x y) (@ env @install-macro! x y))))
     `((quote ,quote-expander) (lambda ,lambda-expander) (if ,if-expander) (closure ,closure-expander) (set! ,set!-expander)
       (let ,let-expander) (let* ,let*-expander) (defmacro ,defmacro-expander)))
    (eval '(defmacro progn (b . bs)
             `((lambda () ,b ,@bs)))
          env)
    (eval '(progn
            (defmacro defun (name xs . body)
              `(set-top! ',name (lambda ,xs ,@body))))
          env)
    (eval '(progn
            (defun eval-seq (xs)
              (if (null? xs)
                  (error eval-seq "empty code sequence")
                  (if (null? (cdr xs))
                      (eval (car xs))
                      (progn (eval (car xs)) (eval-seq (cdr xs))))))
            (defun not (x) (if x #f #t))
            (defun caar (xs) (car (car xs)))
            (defun cadr (xs) (car (cdr xs)))
            (defun cdar (xs) (cdr (car xs)))
            (defun cddr (xs) (cdr (cdr xs))))
          env)
    ;; maybe we should define macros alternatives as fexpr if possible?
    (eval '(progn
            (defmacro cond xs
              (if (null? xs)
                  #f
                  (progn
                   (if (not (list? (car xs)))
                       (error 'cond "bad form ~A" `(cond ,@xs)))
                   (if (< (length (car xs)) 2)
                       (error 'cond "bad form ~A" `(cond ,@xs)))
                   `(if ,(caar xs) (progn ,@(cdar xs)) (cond ,@(cdr xs))))))
            (defun cond xs
              (if (null? xs)
                  #f
                  (if (eval (caar xs))
                      (eval (cdar xs))
                      (apply cond (cdr xs))))))
          env)
    (eval '(progn
            (defun or xs #:fexpr
              (if (null? xs)
                  #f
                  (let ((*or-tmp* (eval (car xs))))
                    (if *or-tmp* *or-tmp* (apply or (cdr xs))))))
            (defmacro or xs
              (if (null? xs)
                  #f
                  `(let ((*or-tmp* ,(car xs)))
                     (if *or-tmp* *or-tmp* (or ,@(cdr xs))))))
            (defun and xs #:fexpr
              (cond ((null? xs) #t)
                    ((null? (cdr xs)) (car xs))
                    ((eval (car xs)) (apply and (cdr xs)))))
            (defmacro and xs
              (cond ((null? xs) #t)
                    ((null? (cdr xs)) (car xs))
                    (#t `(if ,(car xs) (and ,@(cdr xs))))))
            (defun for-each2 (f xs)
              (if ((null? xs))
                  'done
                  (progn (f (car xs)) (for-each2 f (cdr xs)))))
            (defun all? (f xs)
              (call/cc
               (lambda (exit)
                 (closure (exit f)
                   (for-each2 (lambda (x) (if (not (f x)) (exit #f)))))
                 #t)))
            (defun defun xs #:fexpr
              (if (or (>= 2 (length xs))
                      (not (symbol? (car xs)))
                      (and (not (symbol? (cadr xs)))
                           (not (list? (cadr xs)))
                           (all? symbol? (cadr xs)))
                      (not (list? (cddr xs))))
                  (error 'defun "bad defun ~A" `(defun ,@xs)))
              (set-top! (car xs) (eval `(lambda ,(cadr xs) ,@(cddr xs))))))
          env)
    env))

#|
(let ((env (make-std-env)))
  (map
   (lambda (x) (eval x env))
   `((defun or xs #:fexpr
       (if (null? xs) #f (if (eval (car xs)) #t (apply or (cdr xs)))))
     (defun fib (x)
       (if (or (= x 0) (= x 1))
           1
           (+ (fib (- x 1)) (fib (- x 2)))))
     (defun make-counter (x)
       (closure (x)
         (lambda (y)
           (let ((z x))
             (set! x (+ x y)) z))))
     (defun tail-call-test (x)
       (if (< x 100000)
           (tail-call-test (+ x 1))
           'ok))
     (defun forN (top chunck)
       (let (loop)
         (set! loop
           (lambda (*iterate-variable*)
             (if (= *iterate-variable* top)
                 'ok
                 (loop
                  (let ()
                    (chunck *iterate-variable*)
                    (+ *iterate-variable* 1))))))
         (loop 0)))
     (let ((cnt (make-counter 0)))
       (forN 100 (lambda _ (displayf "cnt ~S~%" (cnt 1)))))
     (displayf "fib ~S~%" (fib 11))
     (displayf "tail-call ~S~%" (tail-call-test 0))
     )))
|#