Resurrect Mes in Guile.
[mes.git] / guile / mes.scm
1 #! /bin/sh
2 # -*-scheme-*-
3 exec guile -L $(pwd) -e '(mes)' -s "$0" "$@"
4 !#
5
6 ;;; Mes --- The Maxwell Equations of Software
7 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
8 ;;;
9 ;;; This file is part of GNU Guix.
10 ;;;
11 ;;; Mes is free software; you can redistribute it and/or modify it
12 ;;; under the terms of the GNU General Public License as published by
13 ;;; the Free Software Foundation; either version 3 of the License, or (at
14 ;;; your option) any later version.
15 ;;;
16 ;;; Mes is distributed in the hope that it will be useful, but
17 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
19 ;;; GNU General Public License for more details.
20 ;;;
21 ;;; You should have received a copy of the GNU General Public License
22 ;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
23
24 ;; The Maxwell Equations of Software -- John McCarthy page 13
25 ;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
26
27 (define-module (mes)
28   #:export (main))
29
30 (set-current-module
31  (make-module 10 `(,(resolve-interface
32                      '(guile)
33                      #:select '(
34                                 ;; Debugging
35                                 apply
36                                 cons*
37                                 current-error-port
38                                 current-output-port
39                                 display
40                                 eof-object?
41                                 exit
42                                 force-output
43                                 format
44                                 newline
45                                 read
46                                 with-input-from-string
47
48                                 ;; Guile admin
49                                 module-define!
50                                 resolve-interface
51
52                                 ;; PRIMITIVE BUILTINS
53                                 car
54                                 cdr
55                                 cons
56                                 eq?
57                                 null?
58                                 pair?
59
60                                 ;; READER
61                                 char->integer
62                                 integer->char
63                                 read-char
64                                 unread-char
65                                 
66                                 ;; non-primitive BUILTINS
67                                 char?
68                                 number?
69                                 procedure?
70                                 string?
71                                 <
72                                 -
73                                 )
74                      #:renamer (symbol-prefix-proc 'guile:)))))
75
76 (define (logf port string . rest)
77   (guile:apply guile:format (guile:cons* port string rest))
78   (guile:force-output port)
79   #t)
80
81 (define (stderr string . rest)
82   (guile:apply logf (guile:cons* (guile:current-error-port) string rest)))
83
84 (define (stdout string . rest)
85   (guile:apply logf (guile:cons* (guile:current-output-port) string rest)))
86
87 (define (debug . x) #t)
88 ;;(define debug stderr)
89
90 ;; TODO
91 (define (atom? x)
92   (cond
93    ((guile:pair? x) #f)
94    ((guile:null? x) #f)
95    (#t x)))
96
97 ;; PRIMITIVES
98 (define car guile:car)
99 (define cdr guile:cdr)
100 (define cons guile:cons)
101 (define eq? guile:eq?)
102 (define null? guile:null?)
103 (define pair? guile:pair?)
104 (define builtin? guile:procedure?)
105 (define char? guile:char?)
106 (define number? guile:number?)
107 (define string? guile:number?)
108 (define call guile:apply)
109 (define (peek-byte)
110   (unread-byte (read-byte)))
111 (define (read-byte)
112   (guile:char->integer (guile:read-char)))
113 (define (unread-byte x)
114   (guile:unread-char (guile:integer->char x))
115   x)
116 (define (lookup x a)
117   ;; TODO
118   (stderr "lookup x=~a\n" x)
119   x)
120
121 (include "mes.mes")
122
123 (define (append2 x y)
124   (cond ((null? x) y)
125         (#t (cons (car x) (append2 (cdr x) y)))))
126
127 (define (eval-environment e a)
128   (eval e (append2 a environment)))
129
130 (define (apply-environment fn e a)
131   (apply-env fn e (append2 a environment)))
132
133 ;; READER: TODO lookup
134 (define (readenv a)
135   (let ((x (guile:read)))
136     (if (guile:eof-object? x) '()
137         x)))
138
139 (define environment
140   `(
141     (() . ())
142     (#t . #t)
143     (#f . #f)
144     
145     (*unspecified* . ,*unspecified*)
146
147     (atom? . ,atom?)
148     (car . ,car)
149     (cdr . ,cdr)
150     (cons . ,cons)
151     (cond . ,evcon)
152     (eq? . ,eq?)
153
154     (null? . ,null?)
155     (pair? . ,guile:pair?)
156     ;;(quote . ,quote)
157
158     (evlis . ,evlis)
159     (evcon . ,evcon)
160     (pairlis . ,pairlis)
161     (assq . ,assq)
162
163     (eval . ,eval-environment)
164     (apply-env . ,apply-environment)
165
166     (readenv . ,readenv)
167     (display . ,guile:display)
168     (newline . ,guile:newline)
169
170     (builtin? . ,builtin?)
171     (number? . ,number?)
172     (call . ,call)
173
174     (< . ,guile:<)
175     (- . ,guile:-)
176
177     ;; DERIVED
178     (caar . ,caar)
179     (cadr . ,cadr)
180     (cdar . ,cdar)
181     (cddr . ,cddr)
182     (caadr . ,caadr)
183     (caddr . ,caddr)
184     (cdadr . ,cdadr)
185     (cadar . ,cadar)
186     (cddar . ,cddar)
187     (cdddr . ,cdddr)
188
189     (append2 . ,append2)
190     (exit . ,guile:exit)
191
192     (*macro* . ())
193
194     ;;
195     (stderr . ,stderr)))
196
197 (define (mes-define-lambda x a)
198   (cons (caadr x) (cons 'lambda (cons (cdadr x) (cddr x)))))
199
200 (define (mes-define x a)
201   (if (atom? (cadr x))
202       (cons (cadr x) (eval (caddr x) a))
203       (mes-define-lambda x a)))
204
205 (define (mes-define-macro x a)
206   (cons '*macro*
207         (cons (mes-define-lambda x a)
208               (cdr (assq '*macro* a)))))
209
210 (define (loop r e a)
211   (cond ((null? e) r)
212         ((eq? e 'exit)
213          (apply-env (cdr (assq 'loop a))
214                     (cons *unspecified* (cons #t (cons a '())))
215                     a))
216         ((atom? e) (loop (eval e a) (readenv a) a))
217         ((eq? (car e) 'define)
218          (loop *unspecified* (readenv a) (cons (mes-define e a) a)))
219         ((eq? (car e) 'define-macro)
220          (loop *unspecified* (readenv a) (cons (mes-define-macro e a) a)))
221         (#t (loop (eval e a) (readenv a) a))))
222
223 (define (main arguments)
224   (let ((a (append2 environment `((*a* . ,environment)))))
225     ;;(guile:display (eval (readenv a) a))
226     (guile:display (loop *unspecified* (readenv a) a))
227     )
228   (guile:newline))
229
230 (guile:module-define! (guile:resolve-interface '(mes)) 'main main)