2016-05-15 11:41:40 +00:00
|
|
|
#! /bin/sh
|
|
|
|
# -*-scheme-*-
|
2016-12-12 14:41:48 +00:00
|
|
|
exec guile -L $(pwd) -e '(mes)' -s "$0" "$@"
|
2016-05-15 11:41:40 +00:00
|
|
|
!#
|
|
|
|
|
|
|
|
;;; Mes --- The Maxwell Equations of Software
|
|
|
|
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
|
|
|
|
;;;
|
|
|
|
;;; This file is part of GNU Guix.
|
|
|
|
;;;
|
|
|
|
;;; Mes is free software; you can redistribute it and/or modify it
|
|
|
|
;;; under the terms of the GNU General Public License as published by
|
|
|
|
;;; the Free Software Foundation; either version 3 of the License, or (at
|
|
|
|
;;; your option) any later version.
|
|
|
|
;;;
|
|
|
|
;;; Mes is distributed in the hope that it will be useful, but
|
|
|
|
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
|
;;; GNU General Public License for more details.
|
|
|
|
;;;
|
|
|
|
;;; You should have received a copy of the GNU General Public License
|
|
|
|
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
|
|
|
|
;; The Maxwell Equations of Software -- John McCarthy page 13
|
|
|
|
;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
|
|
|
|
|
2016-05-15 22:07:44 +00:00
|
|
|
(define-module (mes)
|
2016-05-15 11:41:40 +00:00
|
|
|
#:export (main))
|
|
|
|
|
|
|
|
(set-current-module
|
|
|
|
(make-module 10 `(,(resolve-interface
|
|
|
|
'(guile)
|
|
|
|
#:select '(
|
|
|
|
;; Debugging
|
|
|
|
apply
|
|
|
|
cons*
|
|
|
|
current-error-port
|
2016-05-15 22:07:44 +00:00
|
|
|
current-output-port
|
2016-05-15 11:41:40 +00:00
|
|
|
display
|
2016-05-15 22:07:44 +00:00
|
|
|
eof-object?
|
|
|
|
exit
|
2016-05-15 11:41:40 +00:00
|
|
|
force-output
|
|
|
|
format
|
|
|
|
newline
|
2016-05-15 22:07:44 +00:00
|
|
|
read
|
|
|
|
with-input-from-string
|
2016-05-15 11:41:40 +00:00
|
|
|
|
|
|
|
;; Guile admin
|
|
|
|
module-define!
|
|
|
|
resolve-interface
|
|
|
|
|
2016-12-12 14:41:48 +00:00
|
|
|
;; PRIMITIVE BUILTINS
|
2016-05-15 11:41:40 +00:00
|
|
|
car
|
|
|
|
cdr
|
|
|
|
cons
|
|
|
|
eq?
|
|
|
|
null?
|
|
|
|
pair?
|
2016-05-15 22:07:44 +00:00
|
|
|
|
2016-12-12 14:41:48 +00:00
|
|
|
;; READER
|
|
|
|
char->integer
|
|
|
|
integer->char
|
|
|
|
read-char
|
|
|
|
unread-char
|
|
|
|
|
|
|
|
;; non-primitive BUILTINS
|
|
|
|
char?
|
2016-05-15 22:07:44 +00:00
|
|
|
number?
|
|
|
|
procedure?
|
2016-12-12 14:41:48 +00:00
|
|
|
string?
|
2016-05-15 22:07:44 +00:00
|
|
|
<
|
|
|
|
-
|
2016-05-15 11:41:40 +00:00
|
|
|
)
|
|
|
|
#:renamer (symbol-prefix-proc 'guile:)))))
|
|
|
|
|
|
|
|
(define (logf port string . rest)
|
|
|
|
(guile:apply guile:format (guile:cons* port string rest))
|
|
|
|
(guile:force-output port)
|
|
|
|
#t)
|
|
|
|
|
|
|
|
(define (stderr string . rest)
|
|
|
|
(guile:apply logf (guile:cons* (guile:current-error-port) string rest)))
|
|
|
|
|
|
|
|
(define (stdout string . rest)
|
|
|
|
(guile:apply logf (guile:cons* (guile:current-output-port) string rest)))
|
|
|
|
|
|
|
|
(define (debug . x) #t)
|
|
|
|
;;(define debug stderr)
|
|
|
|
|
|
|
|
;; TODO
|
2016-07-09 21:12:25 +00:00
|
|
|
(define (atom? x)
|
2016-05-15 11:41:40 +00:00
|
|
|
(cond
|
|
|
|
((guile:pair? x) #f)
|
|
|
|
((guile:null? x) #f)
|
|
|
|
(#t x)))
|
|
|
|
|
|
|
|
;; PRIMITIVES
|
|
|
|
(define car guile:car)
|
|
|
|
(define cdr guile:cdr)
|
|
|
|
(define cons guile:cons)
|
2016-07-09 21:12:25 +00:00
|
|
|
(define eq? guile:eq?)
|
|
|
|
(define null? guile:null?)
|
|
|
|
(define pair? guile:pair?)
|
|
|
|
(define builtin? guile:procedure?)
|
2016-12-12 14:41:48 +00:00
|
|
|
(define char? guile:char?)
|
2016-07-09 21:12:25 +00:00
|
|
|
(define number? guile:number?)
|
2016-12-12 14:41:48 +00:00
|
|
|
(define string? guile:number?)
|
2016-05-15 22:07:44 +00:00
|
|
|
(define call guile:apply)
|
2016-12-12 14:41:48 +00:00
|
|
|
(define (peek-byte)
|
|
|
|
(unread-byte (read-byte)))
|
|
|
|
(define (read-byte)
|
|
|
|
(guile:char->integer (guile:read-char)))
|
|
|
|
(define (unread-byte x)
|
|
|
|
(guile:unread-char (guile:integer->char x))
|
|
|
|
x)
|
|
|
|
(define (lookup x a)
|
|
|
|
;; TODO
|
|
|
|
(stderr "lookup x=~a\n" x)
|
|
|
|
x)
|
|
|
|
|
|
|
|
(include "mes.mes")
|
|
|
|
|
|
|
|
(define (append2 x y)
|
2016-07-09 21:12:25 +00:00
|
|
|
(cond ((null? x) y)
|
2016-12-12 14:41:48 +00:00
|
|
|
(#t (cons (car x) (append2 (cdr x) y)))))
|
2016-05-15 22:07:44 +00:00
|
|
|
|
|
|
|
(define (eval-environment e a)
|
2016-12-12 14:41:48 +00:00
|
|
|
(eval e (append2 a environment)))
|
2016-05-15 22:07:44 +00:00
|
|
|
|
|
|
|
(define (apply-environment fn e a)
|
2016-12-12 14:41:48 +00:00
|
|
|
(apply-env fn e (append2 a environment)))
|
2016-05-15 22:07:44 +00:00
|
|
|
|
2016-12-12 14:41:48 +00:00
|
|
|
;; READER: TODO lookup
|
2016-05-15 22:07:44 +00:00
|
|
|
(define (readenv a)
|
|
|
|
(let ((x (guile:read)))
|
|
|
|
(if (guile:eof-object? x) '()
|
|
|
|
x)))
|
|
|
|
|
|
|
|
(define environment
|
|
|
|
`(
|
|
|
|
(() . ())
|
|
|
|
(#t . #t)
|
|
|
|
(#f . #f)
|
|
|
|
|
|
|
|
(*unspecified* . ,*unspecified*)
|
|
|
|
|
2016-07-09 21:12:25 +00:00
|
|
|
(atom? . ,atom?)
|
2016-05-15 22:07:44 +00:00
|
|
|
(car . ,car)
|
|
|
|
(cdr . ,cdr)
|
|
|
|
(cons . ,cons)
|
|
|
|
(cond . ,evcon)
|
2016-07-09 21:12:25 +00:00
|
|
|
(eq? . ,eq?)
|
2016-05-15 22:07:44 +00:00
|
|
|
|
2016-07-09 21:12:25 +00:00
|
|
|
(null? . ,null?)
|
|
|
|
(pair? . ,guile:pair?)
|
2016-05-15 22:07:44 +00:00
|
|
|
;;(quote . ,quote)
|
|
|
|
|
|
|
|
(evlis . ,evlis)
|
|
|
|
(evcon . ,evcon)
|
|
|
|
(pairlis . ,pairlis)
|
2016-07-11 08:48:25 +00:00
|
|
|
(assq . ,assq)
|
2016-05-15 22:07:44 +00:00
|
|
|
|
|
|
|
(eval . ,eval-environment)
|
2016-07-16 06:17:56 +00:00
|
|
|
(apply-env . ,apply-environment)
|
2016-05-15 22:07:44 +00:00
|
|
|
|
|
|
|
(readenv . ,readenv)
|
|
|
|
(display . ,guile:display)
|
|
|
|
(newline . ,guile:newline)
|
|
|
|
|
2016-07-09 21:12:25 +00:00
|
|
|
(builtin? . ,builtin?)
|
|
|
|
(number? . ,number?)
|
2016-05-15 22:07:44 +00:00
|
|
|
(call . ,call)
|
|
|
|
|
|
|
|
(< . ,guile:<)
|
|
|
|
(- . ,guile:-)
|
|
|
|
|
|
|
|
;; DERIVED
|
|
|
|
(caar . ,caar)
|
|
|
|
(cadr . ,cadr)
|
|
|
|
(cdar . ,cdar)
|
|
|
|
(cddr . ,cddr)
|
|
|
|
(caadr . ,caadr)
|
|
|
|
(caddr . ,caddr)
|
|
|
|
(cdadr . ,cdadr)
|
|
|
|
(cadar . ,cadar)
|
|
|
|
(cddar . ,cddar)
|
|
|
|
(cdddr . ,cdddr)
|
|
|
|
|
2016-12-12 14:41:48 +00:00
|
|
|
(append2 . ,append2)
|
2016-05-15 22:07:44 +00:00
|
|
|
(exit . ,guile:exit)
|
|
|
|
|
|
|
|
(*macro* . ())
|
|
|
|
|
|
|
|
;;
|
|
|
|
(stderr . ,stderr)))
|
|
|
|
|
|
|
|
(define (mes-define-lambda x a)
|
|
|
|
(cons (caadr x) (cons 'lambda (cons (cdadr x) (cddr x)))))
|
|
|
|
|
|
|
|
(define (mes-define x a)
|
2016-07-09 21:12:25 +00:00
|
|
|
(if (atom? (cadr x))
|
2016-05-15 22:07:44 +00:00
|
|
|
(cons (cadr x) (eval (caddr x) a))
|
|
|
|
(mes-define-lambda x a)))
|
|
|
|
|
|
|
|
(define (mes-define-macro x a)
|
|
|
|
(cons '*macro*
|
|
|
|
(cons (mes-define-lambda x a)
|
2016-07-11 08:48:25 +00:00
|
|
|
(cdr (assq '*macro* a)))))
|
2016-05-15 22:07:44 +00:00
|
|
|
|
|
|
|
(define (loop r e a)
|
2016-07-09 21:12:25 +00:00
|
|
|
(cond ((null? e) r)
|
|
|
|
((eq? e 'exit)
|
2016-07-16 06:17:56 +00:00
|
|
|
(apply-env (cdr (assq 'loop a))
|
|
|
|
(cons *unspecified* (cons #t (cons a '())))
|
|
|
|
a))
|
2016-07-09 21:12:25 +00:00
|
|
|
((atom? e) (loop (eval e a) (readenv a) a))
|
|
|
|
((eq? (car e) 'define)
|
2016-05-15 22:07:44 +00:00
|
|
|
(loop *unspecified* (readenv a) (cons (mes-define e a) a)))
|
2016-07-09 21:12:25 +00:00
|
|
|
((eq? (car e) 'define-macro)
|
2016-05-15 22:07:44 +00:00
|
|
|
(loop *unspecified* (readenv a) (cons (mes-define-macro e a) a)))
|
|
|
|
(#t (loop (eval e a) (readenv a) a))))
|
2016-05-15 11:41:40 +00:00
|
|
|
|
|
|
|
(define (main arguments)
|
2016-12-12 14:41:48 +00:00
|
|
|
(let ((a (append2 environment `((*a* . ,environment)))))
|
2016-05-15 22:07:44 +00:00
|
|
|
;;(guile:display (eval (readenv a) a))
|
|
|
|
(guile:display (loop *unspecified* (readenv a) a))
|
|
|
|
)
|
2016-05-15 11:41:40 +00:00
|
|
|
(guile:newline))
|
|
|
|
|
2016-05-15 22:07:44 +00:00
|
|
|
(guile:module-define! (guile:resolve-interface '(mes)) 'main main)
|