mescc: Refactor type system: struct/enum fields: (name . <type>).
[mes.git] / guile / mes.mes
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016,2018 Jan (janneke) 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-env 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 ;;return make_cell_ (tmp_num_ (TCLOSURE), cell_f, cons (cons (cell_circular, a), cons (formals, body)));
93 (define (make-closure formals body a)
94   (cons (cons '*closure* #f) (cons (cons '*circ* a) (cons formals body))))
95
96 (define (eval-expand e a)
97   (cond
98    ((eq? e '*undefined*) e)
99    ((symbol? e) (assq-ref-env e a))
100    ((atom? e) e)
101    ((atom? (car e))
102     (cond
103      ((eq? (car e) 'quote) (cadr e))
104      ((eq? (car e) 'syntax) (cadr e))
105      ((eq? (car e) 'begin) (eval-begin-env e a))
106      ((eq? (car e) 'lambda) e)
107      ((eq? (car e) 'lambda) (make-closure (cadr e) (cddr e) (assq '*closure* a)))
108      ((eq? (car e) '*closure*) e)
109      ((eq? (car e) 'if) (eval-if-env (cdr e) a))
110      ((eq? (car e) 'define) (env:define (cons (sexp:define e a) '()) a))
111      ((eq? (car e) 'define-macro) (env:define (env:macro (sexp:define e a)) a))
112      ((eq? (car e) 'set!) (set-env! (cadr e) (eval-env (caddr e) a) a))
113      ((eq? (car e) 'apply-env) (apply-env (eval-env (cadr e) a) (evlis-env (caddr e) a) a))
114      ((eq? (car e) 'unquote) (eval-env (cadr e) a))
115      ((eq? (car e) 'quasiquote) (eval-quasiquote (cadr e) (add-unquoters a)))
116      (#t (apply-env (eval-env (car e) a) (evlis-env (cdr e) a) a))))
117    (#t (apply-env (eval-env (car e) a) (evlis-env (cdr e) a) a))))
118
119 (define (unquote x) (cons 'unquote x))
120 (define (unquote-splicing x) (cons 'quasiquote x))
121
122 (define %the-unquoters
123   (cons
124    (cons 'unquote unquote)
125    (cons (cons 'unquote-splicing unquote-splicing) '())))
126
127 (define (add-unquoters a)
128   (cons %the-unquoters a))
129
130 (define (eval-env e a)
131   (eval-expand (macro-expand-env e a) a))
132
133 (define (macro-expand-env e a)
134   (if (pair? e) ((lambda (macro)
135                    (if macro (macro-expand-env (apply-env macro (cdr e) a) a)
136                        e))
137                  (lookup-macro (car e) a))
138       e))
139
140 (define (eval-begin-env e a)
141   (if (null? e) *unspecified*
142       (if (null? (cdr e)) (eval-env (car e) a)
143           (begin
144             (eval-env (car e) a)
145             (eval-begin-env (cdr e) a)))))
146
147 (define (eval-if-env e a)
148   (if (eval-env (car e) a) (eval-env (cadr e) a)
149       (if (pair? (cddr e)) (eval-env (caddr e) a))))
150
151 ;; (define (eval-quasiquote e a)
152 ;;   (cond ((null? e) e)
153 ;;         ((atom? e) e)
154 ;;         ((eq? (car e) 'unquote) (eval-env (cadr e) a))
155 ;;         ((and (pair? (car e))
156 ;;               (eq? (caar e) 'unquote-splicing))
157 ;;          (append2 (eval-env (cadar e) a) (eval-quasiquote (cdr e) a)))
158 ;;         (#t (cons (eval-quasiquote (car e) a) (eval-quasiquote (cdr e) a)))))
159
160 (define (sexp:define e a)
161   (if (atom? (cadr e)) (cons (cadr e) (eval-env (caddr e) a))
162       (cons (caadr e) (eval-env (cons 'lambda (cons (cdadr e) (cddr e))) a))))
163
164 (define (env:define a+ a)
165   (set-cdr! a+ (cdr a))
166   (set-cdr! a a+)
167   (set-cdr! (assq '*closure* a) a))
168
169 (define (env:macro name+entry)
170   (cons
171    (cons (car name+entry)
172          (make-macro (car name+entry)
173                      (cdr name+entry)))
174    '()))