25e7b25dd4d3ca7d911e9a7a9c6a3ea752069143
[mes.git] / 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 (macro-expand-env e a) a))
127
128 (define (macro-expand-env e a)
129   (if (pair? e) ((lambda (macro)
130                    (if macro (macro-expand-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    '()))