mes/module/mes/mes-0.mes

;;; -*-scheme-*-

;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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/>.

;;; Commentary:

;;; mes-0.mes - bootstrap into Scheme, re

;;; When compiling mes.c with -DBOOT=1, eval/apply et al. are lacking
;;; features wrt the fat-c variant, e.g., define and define-macro are
;;; not available; instead label is supplied.  Before loading
;;; boot-0.mes, loop-0.mes is loaded to provide a richer eval/apply.

;;; This might enable moving more functionality from C to Scheme,
;;; making the entirely-from-source bootstrap process more feasible.
;;; However, currently performance is 400x worse.  Also several tests
;;; in the test suite fail and the REPL does not work yet.

;;; Code:

(define-macro (cond . clauses)
  (list 'if (null? clauses) *unspecified*
        (if (null? (cdr clauses))
            (list 'if (car (car clauses))
                  (list (cons 'lambda (cons '() (cons (car (car clauses)) (cdr (car clauses))))))
                  *unspecified*)
            (if (eq? (car (cadr clauses)) 'else)
                (list 'if (car (car clauses))
                      (list (cons 'lambda (cons '() (car clauses))))
                      (list (cons 'lambda (cons '() (cons *unspecified* (cdr (cadr clauses)))))))
                (list 'if (car (car clauses))
                      (list (cons 'lambda (cons '() (car clauses))))
                      (cons 'cond (cdr clauses)))))))

(define (map f l . r)
  (if (null? l) '()
      (if (null? r) (cons (f (car l)) (map f (cdr l)))
          (if (null? (cdr r))
              (cons (f (car l) (caar r)) (map f (cdr l) (cdar r)))))))

(define-macro (simple-let bindings . rest)
  (cons (cons 'lambda (cons (map car bindings) rest))
        (map cadr bindings)))

(define-macro (let bindings . rest)
  (cons 'simple-let (cons bindings rest)))

(define-macro (or . x)
  (if (null? x) #f
      (if (null? (cdr x)) (car x)
          (list 'if (car x) (car x)
                (cons 'or (cdr x))))))

(define-macro (and . x)
  (if (null? x) #t
      (if (null? (cdr x)) (car x)
          (list 'if (car x) (cons 'and (cdr x))
                #f))))

(define (not x)
  (if x #f #t))

(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)
     (#t (apply-env (eval-env fn a) x 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
   ((symbol? e) (assq-ref-env 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 (car e) (evlis-env (cdr e) a) a))))
   (#t (apply-env (car e) (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 (macro-expand-env e a) a))

(define (macro-expand-env e a)
  (if (pair? e) ((lambda (macro)
                   (if macro (macro-expand-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)))
   '()))

;; boot into loop-0
()