mes/guile/mes.mes

;;; -*-scheme-*-

;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; mes.mes: This file is part of Mes.
;;;
;;; Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.

;; The Maxwell Equations of Software -- John McCarthy page 13
;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf

(define (caar x) (car (car x)))
(define (cadr x) (car (cdr x)))
(define (cdar x) (cdr (car x)))
(define (cddr x) (cdr (cdr x)))
(define (caadr x) (car (car (cdr x))))
(define (caddr x) (car (cdr (cdr x))))
(define (cddar x) (cdr (cdr (car x))))
(define (cdadr x) (cdr (car (cdr x))))
(define (cadar x) (car (cdr (car x))))
(define (cdddr x) (cdr (cdr (cdr x))))

;; Page 12
(define (pairlis x y a)
  (cond
   ((null? x) a)
   ((atom? x) (cons (cons x y) a))
   (#t (cons (cons (car x) (car y))
             (pairlis (cdr x) (cdr y) a)))))

(define (assq x a)
  (cond
   ((null? a) #f)
   ((eq? (caar a) x) (car a))
   (#t (assq x (cdr a)))))

(define (assq-ref-cache x a)
  (let ((e (assq x a)))
    (if (eq? e #f) '*undefined* (cdr e))))

;; Page 13
(define (evcon c a)
  (cond
   ((null? c) *unspecified*)
   ;; single-statement cond
   ;; ((eval (caar c) a) (eval (cadar c) a))
   ((eval (caar c) a)
    (cond ((null? (cddar c)) (eval (cadar c) a))
          (#t (eval (cadar c) a)
              (evcon
               (cons (cons #t (cddar c)) '())
               a))))
   (#t (evcon (cdr c) a))))

(define (evlis-env m a)
  (cond
   ((null? m) '())
   ((not (pair? m)) (eval-env m a))
   (#t (cons (eval-env (car m) a) (evlis-env (cdr m) a)))))

(define (apply-env fn x a) 
  (cond
   ((atom? fn)
    (cond
     ((builtin? fn) (call fn x))
     ((eq? fn 'call-with-values) (call call-with-values-env (append x (cons a '()))))
     ((eq? fn 'current-module) a)))
   ((eq? (car fn) 'lambda)
    (let ((p (pairlis (cadr fn) x a)))
      (eval-begin-env (cddr fn) (cons (cons '*closure* p) p))))
   ((eq? (car fn) '*closure*)
    (let ((args (caddr fn))
          (body (cdddr fn))
          (a (cddr (cadr fn))))
      (let ((p (pairlis args x a)))
        (eval-begin-env body (cons (cons '*closure* p) p)))))
   ;;((eq? (car fn) 'label) (apply-env (caddr fn) x (cons (cons (cadr fn) (caddr fn)) a)))
   (#t (apply-env (eval-env fn a) x a))))

(define (eval-expand e a)
  (cond
   ((eq? e '*undefined*) e)
   ((symbol? e) (assq-ref-cache e a))
   ((atom? e) e)
   ((atom? (car e))
    (cond
     ((eq? (car e) 'quote) (cadr e))
     ((eq? (car e) 'syntax) (cadr e))
     ((eq? (car e) 'begin) (eval-begin-env e a))
     ((eq? (car e) 'lambda) (make-closure (cadr e) (cddr e) (assq '*closure* a)))
     ((eq? (car e) '*closure*) e)
     ((eq? (car e) 'if) (eval-if-env (cdr e) a))
     ((eq? (car e) 'define) (env:define (cons (sexp:define e a) '()) a))
     ((eq? (car e) 'define-macro) (env:define (env:macro (sexp:define e a)) a))
     ((eq? (car e) 'set!) (set-env! (cadr e) (eval-env (caddr e) a) a))
     ((eq? (car e) 'apply-env) (apply-env (eval-env (cadr e) a) (evlis-env (caddr e) a) a))
     ((eq? (car e) 'unquote) (eval-env (cadr e) a))
     ((eq? (car e) 'quasiquote) (eval-quasiquote (cadr e) (add-unquoters a)))
     (#t (apply-env (eval-env (car e) a) (evlis-env (cdr e) a) a))))
   (#t (apply-env (eval-env (car e) a) (evlis-env (cdr e) a) a))))

(define (unquote x) (cons 'unquote x))
(define (unquote-splicing x) (cons 'quasiquote x))

(define %the-unquoters
  (cons
   (cons 'unquote unquote)
   (cons (cons 'unquote-splicing unquote-splicing) '())))

(define (add-unquoters a)
  (cons %the-unquoters a))

(define (eval-env e a)
  (eval-expand (expand-macro-env e a) a))

(define (expand-macro-env e a)
  (if (pair? e) ((lambda (macro)
                   (if macro (expand-macro-env (apply-env macro (cdr e) a) a)
                       e))
                 (lookup-macro (car e) a))
      e))

(define (eval-begin-env e a)
  (if (null? e) *unspecified*
      (if (null? (cdr e)) (eval-env (car e) a)
          (begin
            (eval-env (car e) a)
            (eval-begin-env (cdr e) a)))))

(define (eval-if-env e a)
  (if (eval-env (car e) a) (eval-env (cadr e) a)
      (if (pair? (cddr e)) (eval-env (caddr e) a))))

(define (eval-quasiquote e a)
  (cond ((null? e) e)
        ((atom? e) e)
        ((eq? (car e) 'unquote) (eval-env (cadr e) a))
        ((and (pair? (car e))
              (eq? (caar e) 'unquote-splicing))
         (append2 (eval-env (cadar e) a) (eval-quasiquote (cdr e) a)))
        (#t (cons (eval-quasiquote (car e) a) (eval-quasiquote (cdr e) a)))))

(define (sexp:define e a)
  (if (atom? (cadr e)) (cons (cadr e) (eval-env (caddr e) a))
      (cons (caadr e) (eval-env (cons 'lambda (cons (cdadr e) (cddr e))) a))))

(define (env:define a+ a)
  (set-cdr! a+ (cdr a))
  (set-cdr! a a+)
  (set-cdr! (assq '*closure* a) a))

(define (env:macro name+entry)
  (cons
   (cons (car name+entry)
         (make-macro (car name+entry)
                     (cdr name+entry)))
   '()))