guile/mes.mes

   1 ;;; -*-scheme-*-
   2
   3 ;;; Mes --- Maxwell Equations of Software
   4 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
   5 ;;;
   6 ;;; mes.mes: 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 ;; The Maxwell Equations of Software -- John McCarthy page 13
  22 ;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
  23
  24 (define (caar x) (car (car x)))
  25 (define (cadr x) (car (cdr x)))
  26 (define (cdar x) (cdr (car x)))
  27 (define (cddr x) (cdr (cdr x)))
  28 (define (caadr x) (car (car (cdr x))))
  29 (define (caddr x) (car (cdr (cdr x))))
  30 (define (cddar x) (cdr (cdr (car x))))
  31 (define (cdadr x) (cdr (car (cdr x))))
  32 (define (cadar x) (car (cdr (car x))))
  33 (define (cdddr x) (cdr (cdr (cdr x))))
  34
  35 ;; Page 12
  36 (define (pairlis x y a)
  37   (cond
  38    ((null? x) a)
  39    ((atom? x) (cons (cons x y) a))
  40    (#t (cons (cons (car x) (car y))
  41              (pairlis (cdr x) (cdr y) a)))))
  42
  43 (define (assq x a)
  44   (cond
  45    ((null? a) #f)
  46    ((eq? (caar a) x) (car a))
  47    (#t (assq x (cdr a)))))
  48
  49 (define (assq-ref-cache x a)
  50   (let ((e (assq x a)))
  51     (if (eq? e #f) '*undefined* (cdr e))))
  52
  53 ;; Page 13
  54 (define (evcon c a)
  55   (cond
  56    ((null? c) *unspecified*)
  57    ;; single-statement cond
  58    ;; ((eval (caar c) a) (eval (cadar c) a))
  59    ((eval (caar c) a)
  60     (cond ((null? (cddar c)) (eval (cadar c) a))
  61           (#t (eval (cadar c) a)
  62               (evcon
  63                (cons (cons #t (cddar c)) '())
  64                a))))
  65    (#t (evcon (cdr c) a))))
  66
  67 (define (evlis-env m a)
  68   (cond
  69    ((null? m) '())
  70    ((not (pair? m)) (eval-env m a))
  71    (#t (cons (eval-env (car m) a) (evlis-env (cdr m) a)))))
  72
  73 (define (apply-env fn x a)
  74   (cond
  75    ((atom? fn)
  76     (cond
  77      ((builtin? fn) (call fn x))
  78      ((eq? fn 'call-with-values) (call call-with-values-env (append x (cons a '()))))
  79      ((eq? fn 'current-module) a)))
  80    ((eq? (car fn) 'lambda)
  81     (let ((p (pairlis (cadr fn) x a)))
  82       (eval-begin-env (cddr fn) (cons (cons '*closure* p) p))))
  83    ((eq? (car fn) '*closure*)
  84     (let ((args (caddr fn))
  85           (body (cdddr fn))
  86           (a (cddr (cadr fn))))
  87       (let ((p (pairlis args x a)))
  88         (eval-begin-env body (cons (cons '*closure* p) p)))))
  89    ;;((eq? (car fn) 'label) (apply-env (caddr fn) x (cons (cons (cadr fn) (caddr fn)) a)))
  90    (#t (apply-env (eval-env fn a) x a))))
  91
  92 (define (eval-expand e a)
  93   (cond
  94    ((eq? e '*undefined*) e)
  95    ((symbol? e) (assq-ref-cache e a))
  96    ((atom? e) e)
  97    ((atom? (car e))
  98     (cond
  99      ((eq? (car e) 'quote) (cadr e))
 100      ((eq? (car e) 'syntax) (cadr e))
 101      ((eq? (car e) 'begin) (eval-begin-env e a))
 102      ((eq? (car e) 'lambda) (make-closure (cadr e) (cddr e) (assq '*closure* a)))
 103      ((eq? (car e) '*closure*) e)
 104      ((eq? (car e) 'if) (eval-if-env (cdr e) a))
 105      ((eq? (car e) 'define) (env:define (cons (sexp:define e a) '()) a))
 106      ((eq? (car e) 'define-macro) (env:define (env:macro (sexp:define e a)) a))
 107      ((eq? (car e) 'set!) (set-env! (cadr e) (eval-env (caddr e) a) a))
 108      ((eq? (car e) 'apply-env) (apply-env (eval-env (cadr e) a) (evlis-env (caddr e) a) a))
 109      ((eq? (car e) 'unquote) (eval-env (cadr e) a))
 110      ((eq? (car e) 'quasiquote) (eval-quasiquote (cadr e) (add-unquoters a)))
 111      (#t (apply-env (eval-env (car e) a) (evlis-env (cdr e) a) a))))
 112    (#t (apply-env (eval-env (car e) a) (evlis-env (cdr e) a) a))))
 113
 114 (define (unquote x) (cons 'unquote x))
 115 (define (unquote-splicing x) (cons 'quasiquote x))
 116
 117 (define %the-unquoters
 118   (cons
 119    (cons 'unquote unquote)
 120    (cons (cons 'unquote-splicing unquote-splicing) '())))
 121
 122 (define (add-unquoters a)
 123   (cons %the-unquoters a))
 124
 125 (define (eval-env e a)
 126   (eval-expand (expand-macro-env e a) a))
 127
 128 (define (expand-macro-env e a)
 129   (if (pair? e) ((lambda (macro)
 130                    (if macro (expand-macro-env (apply-env macro (cdr e) a) a)
 131                        e))
 132                  (lookup-macro (car e) a))
 133       e))
 134
 135 (define (eval-begin-env e a)
 136   (if (null? e) *unspecified*
 137       (if (null? (cdr e)) (eval-env (car e) a)
 138           (begin
 139             (eval-env (car e) a)
 140             (eval-begin-env (cdr e) a)))))
 141
 142 (define (eval-if-env e a)
 143   (if (eval-env (car e) a) (eval-env (cadr e) a)
 144       (if (pair? (cddr e)) (eval-env (caddr e) a))))
 145
 146 (define (eval-quasiquote e a)
 147   (cond ((null? e) e)
 148         ((atom? e) e)
 149         ((eq? (car e) 'unquote) (eval-env (cadr e) a))
 150         ((and (pair? (car e))
 151               (eq? (caar e) 'unquote-splicing))
 152          (append2 (eval-env (cadar e) a) (eval-quasiquote (cdr e) a)))
 153         (#t (cons (eval-quasiquote (car e) a) (eval-quasiquote (cdr e) a)))))
 154
 155 (define (sexp:define e a)
 156   (if (atom? (cadr e)) (cons (cadr e) (eval-env (caddr e) a))
 157       (cons (caadr e) (eval-env (cons 'lambda (cons (cdadr e) (cddr e))) a))))
 158
 159 (define (env:define a+ a)
 160   (set-cdr! a+ (cdr a))
 161   (set-cdr! a a+)
 162   (set-cdr! (assq '*closure* a) a))
 163
 164 (define (env:macro name+entry)
 165   (cons
 166    (cons (car name+entry)
 167          (make-macro (car name+entry)
 168                      (cdr name+entry)))
 169    '()))