module/mes/mes-0.mes

   1 ;;; -*-scheme-*-
   2
   3 ;;; Mes --- Maxwell Equations of Software
   4 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
   5 ;;;
   6 ;;; This file is part of Mes.
   7 ;;;
   8 ;;; Mes is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; Mes is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 ;;; Commentary:
  22
  23 ;;; mes-0.mes - bootstrap into Scheme, re
  24
  25 ;;; When compiling mes.c with -DBOOT=1, eval/apply et al. are lacking
  26 ;;; features wrt the fat-c variant, e.g., define and define-macro are
  27 ;;; not available; instead label is supplied.  Before loading
  28 ;;; boot-0.mes, loop-0.mes is loaded to provide a richer eval/apply.
  29
  30 ;;; This might enable moving more functionality from C to Scheme,
  31 ;;; making the entirely-from-source bootstrap process more feasible.
  32 ;;; However, currently performance is 400x worse.  Also several tests
  33 ;;; in the test suite fail and the REPL does not work yet.
  34
  35 ;;; Code:
  36
  37 (define-macro (cond . clauses)
  38   (list 'if (null? clauses) *unspecified*
  39         (if (null? (cdr clauses))
  40             (list 'if (car (car clauses))
  41                   (list (cons 'lambda (cons '() (cons (car (car clauses)) (cdr (car clauses))))))
  42                   *unspecified*)
  43             (if (eq? (car (cadr clauses)) 'else)
  44                 (list 'if (car (car clauses))
  45                       (list (cons 'lambda (cons '() (car clauses))))
  46                       (list (cons 'lambda (cons '() (cons *unspecified* (cdr (cadr clauses)))))))
  47                 (list 'if (car (car clauses))
  48                       (list (cons 'lambda (cons '() (car clauses))))
  49                       (cons 'cond (cdr clauses)))))))
  50
  51 (define (map f l . r)
  52   (if (null? l) '()
  53       (if (null? r) (cons (f (car l)) (map f (cdr l)))
  54           (if (null? (cdr r))
  55               (cons (f (car l) (caar r)) (map f (cdr l) (cdar r)))))))
  56
  57 (define-macro (simple-let bindings . rest)
  58   (cons (cons 'lambda (cons (map car bindings) rest))
  59         (map cadr bindings)))
  60
  61 (define-macro (let bindings . rest)
  62   (cons 'simple-let (cons bindings rest)))
  63
  64 (define-macro (or . x)
  65   (if (null? x) #f
  66       (if (null? (cdr x)) (car x)
  67           (list 'if (car x) (car x)
  68                 (cons 'or (cdr x))))))
  69
  70 (define-macro (and . x)
  71   (if (null? x) #t
  72       (if (null? (cdr x)) (car x)
  73           (list 'if (car x) (cons 'and (cdr x))
  74                 #f))))
  75
  76 (define (not x)
  77   (if x #f #t))
  78
  79 (define (evlis-env m a)
  80   (cond
  81    ((null? m) '())
  82    ((not (pair? m)) (eval-env m a))
  83    (#t (cons (eval-env (car m) a) (evlis-env (cdr m) a)))))
  84
  85 (define (apply-env fn x a)
  86   (cond
  87    ((atom? fn)
  88     (cond
  89      ((builtin? fn) (call fn x))
  90      ((eq? fn 'call-with-values) (call call-with-values-env (append x (cons a '()))))
  91      ((eq? fn 'current-module) a)
  92      (#t (apply-env (eval-env fn a) x a))))
  93    ((eq? (car fn) 'lambda)
  94     (let ((p (pairlis (cadr fn) x a)))
  95       (eval-begin-env (cddr fn) (cons (cons '*closure* p) p))))
  96    ((eq? (car fn) '*closure*)
  97     (let ((args (caddr fn))
  98           (body (cdddr fn))
  99           (a (cddr (cadr fn))))
 100       (let ((p (pairlis args x a)))
 101         (eval-begin-env body (cons (cons '*closure* p) p)))))
 102    ;;((eq? (car fn) 'label) (apply-env (caddr fn) x (cons (cons (cadr fn) (caddr fn)) a)))
 103    (#t (apply-env (eval-env fn a) x a))))
 104
 105 (define (eval-expand e a)
 106   (cond
 107    ((symbol? e) (assq-ref-cache e a))
 108    ((atom? e) e)
 109    ((atom? (car e))
 110     (cond
 111      ((eq? (car e) 'quote) (cadr e))
 112      ((eq? (car e) 'syntax) (cadr e))
 113      ((eq? (car e) 'begin) (eval-begin-env e a))
 114      ((eq? (car e) 'lambda) (make-closure (cadr e) (cddr e) (assq '*closure* a)))
 115      ((eq? (car e) '*closure*) e)
 116      ((eq? (car e) 'if) (eval-if-env (cdr e) a))
 117      ((eq? (car e) 'define) (env:define (cons (sexp:define e a) '()) a))
 118      ((eq? (car e) 'define-macro) (env:define (env:macro (sexp:define e a)) a))
 119      ((eq? (car e) 'set!) (set-env! (cadr e) (eval-env (caddr e) a) a))
 120      ((eq? (car e) 'apply-env) (apply-env (eval-env (cadr e) a) (evlis-env (caddr e) a) a))
 121      ((eq? (car e) 'unquote) (eval-env (cadr e) a))
 122      ((eq? (car e) 'quasiquote) (eval-quasiquote (cadr e) (add-unquoters a)))
 123      (#t (apply-env (car e) (evlis-env (cdr e) a) a))))
 124    (#t (apply-env (car e) (evlis-env (cdr e) a) a))))
 125
 126 (define (unquote x) (cons 'unquote x))
 127 (define (unquote-splicing x) (cons 'quasiquote x))
 128
 129 (define %the-unquoters
 130   (cons
 131    (cons 'unquote unquote)
 132    (cons (cons 'unquote-splicing unquote-splicing) '())))
 133
 134 (define (add-unquoters a)
 135   (cons %the-unquoters a))
 136
 137 (define (eval-env e a)
 138   (eval-expand (expand-macro-env e a) a))
 139
 140 (define (expand-macro-env e a)
 141   (if (pair? e) ((lambda (macro)
 142                    (if macro (expand-macro-env (apply-env macro (cdr e) a) a)
 143                        e))
 144                  (lookup-macro (car e) a))
 145       e))
 146
 147 (define (eval-begin-env e a)
 148   (if (null? e) *unspecified*
 149       (if (null? (cdr e)) (eval-env (car e) a)
 150           (begin
 151             (eval-env (car e) a)
 152             (eval-begin-env (cdr e) a)))))
 153
 154 (define (eval-if-env e a)
 155   (if (eval-env (car e) a) (eval-env (cadr e) a)
 156       (if (pair? (cddr e)) (eval-env (caddr e) a))))
 157
 158 (define (eval-quasiquote e a)
 159   (cond ((null? e) e)
 160         ((atom? e) e)
 161         ((eq? (car e) 'unquote) (eval-env (cadr e) a))
 162         ((and (pair? (car e))
 163               (eq? (caar e) 'unquote-splicing))
 164          (append2 (eval-env (cadar e) a) (eval-quasiquote (cdr e) a)))
 165         (#t (cons (eval-quasiquote (car e) a) (eval-quasiquote (cdr e) a)))))
 166
 167 (define (sexp:define e a)
 168   (if (atom? (cadr e)) (cons (cadr e) (eval-env (caddr e) a))
 169       (cons (caadr e) (eval-env (cons 'lambda (cons (cdadr e) (cddr e))) a))))
 170
 171 (define (env:define a+ a)
 172   (set-cdr! a+ (cdr a))
 173   (set-cdr! a a+)
 174   (set-cdr! (assq '*closure* a) a))
 175
 176 (define (env:macro name+entry)
 177   (cons
 178    (cons (car name+entry)
 179          (make-macro (car name+entry)
 180                      (cdr name+entry)))
 181    '()))
 182
 183 ;; boot into loop-0
 184 ()