minimal scheme with an ability to call elisp functions. elispの練習で書いた

schel.el

(setq max-lisp-eval-depth 10000)
(setq max-specpdl-size 10000)
(setq debug-on-error t)

(defun compile (x next)
  (cond
   ((symbolp x) (list 'refer x next)) ;;variables
   ((listp x)
    (let ((code (car x)) (arg (cdr x)))
      (cond
       ((equal code 'schel) ;;native funcall
        (list 'native 
              (car arg) 
              (mapcar '(lambda (it) (compile it '(halt))) (cdr arg))
              next))
       ((equal code 'quote) (list 'constant (car arg) next)) ;;quote
       ((equal code 'lambda_) ;;lambda takes variable number of arguments
        (list 'close (car arg) (recursive-compile (cdr arg) '(return_)) next))
       ((equal code 'if)
        (let ((thenc (compile (cadr arg) next))
              (elsec (compile (caddr arg) next)))
          (compile (car arg) (list 'test thenc elsec))))
       ((equal code 'setq)
        (compile (cadr arg) (list 'assign (car arg) next)))
       ((equal code 'callcc)
        (let ((c (list 'conti
                       (list 'argument
                             (compile (car arg) '(apply))))))
          (list 'frame next c)))
       (t ;;funcall
        (let ((recur '(lambda (args c)
                        (if (null args)
                            (list 'frame next c)
                          (funcall recur (cdr args)
                                 (compile (car args)
                                          (list 'argument c)))))))
          (funcall recur (cdr x) (compile (car x) '(apply))))))))
   (t (list 'constant x next)))) ;;constants

(defun recursive-compile (lis end)
  (if (null lis) end
    (compile (car lis) (recursive-compile (cdr lis) end))))

(defun extend (env vars vals)
  (cons (cons vars vals) env))

;; a: the accumulator
;; x: the next expression
;; e: the current environment
;; r: the current value rib
;; s: the current stack (p51)

(defun VM (a x e r s)
;;  (sit-for 0.1)
;;  (message "acum: %s" a)
;;  (message "xecu: %s" x)
;;  (message "env : %s" e)
;;  (message "rib : %s" r)
;;  (message "stak: %s" s)
;;  (message "%s" " ")
  (let ((code (car x))
        (arg (cdr x)))
    (cond
     ((equal code 'halt) a)
     ((equal code 'native)  ;;call an elisp function
      (let* ((params (mapcar '(lambda (x) (VM a x e r s)) (cadr arg)))
             (result (apply (car arg) params)))
        (VM result (caddr arg) e r s)))
     ((equal code 'refer)
      (VM (car (lookup (car arg) e)) (cadr arg) e r s))
     ((equal code 'constant)
      (VM (car arg) (cadr arg) e r s))
     ((equal code 'close)
      (VM (closure (cadr arg) e (car arg)) (caddr arg) e r s))
     ((equal code 'test) 
      (VM a (if a (car arg) (cadr arg)) e r s))
     ((equal code 'assign) 
      (progn
        (setcar (lookup (car arg) e) a)
        (VM a (cadr arg) e r s)))
     ((equal code 'conti) 
      (VM (continuation s) (car arg) e r s))
     ((equal code 'nuate) 
      (VM (car (lookup (cadr arg) e) '(return_) e r (car arg))))
     ((equal code 'frame) 
      (VM a (cadr arg) e '() (call-frame (car arg) e r s)))
     ((equal code 'argument) 
      (VM a (car arg) e (cons a r) s))
     ((equal code 'apply)
      (let ((body (car a)) (e (cadr a)) (vars (caddr a)))
        (VM a body (extend e vars r) '() s)))
     ((equal code 'return_)
      (let ((x (car s)) (e (cadr s)) (r (caddr s)) (s (cadddr s)))
        (VM a x e r s)))
     (t (progn
          (message "%s %s" "undefined instruction" code)
          (error "undefined instruction")
          nil)))))

(defun p (txt)
  (message "%s" txt)
  txt)

(defun lookup (var env)
  (let ((nxtrib '(lambda (e_)
                    (if (null e_) (error "lookup failed")
                      (let ((nxtelt '(lambda (vars vals)
                                       (cond
                                        ((null vars) (funcall nxtrib (cdr e_)))
                                        ((equal (car vars) var) vals)
                                        (t (funcall nxtelt (cdr vars) (cdr vals)))))))
                        (funcall nxtelt (caar e_) (cdar e_)))))))
    (funcall nxtrib env)))

(lookup 'y '(((x y) 2 3)))

(defun closure (body e_ vars)
  (list body e_ vars))

(defun continuation (s_)
  (closure (list 'nuate s_ 'v) '() '(v)))

(defun call-frame (x_ e_ r_ s_)
  (list x_ e_ r_ s_))

(defun evaluate (lis)
  (VM '() (recursive-compile lis '(halt)) '() '() '()))

;;;;;; examples ;;;;;;

;;calling schel functions with atoms
(evaluate '((schel + 1 2 ((lambda_ (x) x) 3)) ))

(evaluate '(
            ((lambda_ (mes fn1 fn2)
                      ;;aliasing native functions
                      ;;it is Lisp-1 meaning that functions and variables are in the same namespace
                      (setq mes (lambda_ (format text) 
                                             (schel message format text)))
                      (mes "%s" "helloooo")
                      
                      ;;Scheme is lexically scoped
                      (setq fn1 (lambda_ (local1) (fn2)))
                      (setq fn2 (lambda_ () (mes "%s" local1)))
                      ;;(fn1 5656) ;;throws lookup failure signal

                      ) 0 0 0)
            
            ;;anonimous functions passed to schel have to be wrapped in a (quote)
            (schel mapcar (quote (lambda (x) (message "%s" x))) (schel list 1 2 3))
            ))

;;elisp is dynamically scoped
(defun fn1 (local1) (fn2))
(defun fn2 () (message "%s" local1))
(fn1 5656) ;;outputs "5656"