mes/mes.scm

183 lines
5.3 KiB
Scheme
Raw Normal View History

#! /bin/sh
# -*-scheme-*-
exec guile -L $(pwd) -e '(scm)' -s "$0" "$@"
!#
;;; 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
(define-module (scm)
#:export (main))
(set-current-module
(make-module 10 `(,(resolve-interface
'(guile)
#:select '(
;; Debugging
apply
cons*
current-output-port
current-error-port
display
force-output
format
newline
;; Guile admin
module-define!
resolve-interface
;; PRIMITIVES
car
cdr
cons
eq?
null?
pair?
)
#: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
(define (atom x)
(cond
((guile:pair? x) #f)
((guile:null? x) #f)
(#t x)))
;; PRIMITIVES
(define car guile:car)
(define cdr guile:cdr)
(define cons guile:cons)
(define eq guile:eq?)
(define null guile:null?)
(define ATOM 'atom)
(define CAR 'car)
(define CDR 'cdr)
(define COND 'cond)
(define CONS 'cons)
(define EQ 'eq)
(define LABEL 'label)
(define LAMBDA 'lambda)
(define NIL '())
(define QUOTE 'quote)
(define (caar x) (guile:car (guile:car x)))
(define (cadr x) (guile:car (guile:cdr x)))
(define (cdar x) (guile:car (guile:cdr (guile:car x))))
(define (caddr x) (guile:car (guile:cdr (guile:cdr x))))
(define (cadar x) (guile:car (guile:cdr (guile:car x))))
;; Page 12
(define (pairlis x y a)
(debug "pairlis x=~a y=~a a=~a\n" x y a)
(cond
((null x) a)
(#t (cons (cons (car x) (car y))
(pairlis (cdr x) (cdr y) a)))))
(define (assoc x a)
(debug "assoc x=~a a=~a\n" x a)
(cond
((eq (caar a) x) (car a))
(#t (assoc x (cdr a)))))
;; Page 13
(define (eval-quote fn x)
(debug "eval-quote fn=~a x=~a" fn x)
(apply fn x NIL))
(define (apply fn x a)
(debug "apply fn=~a x=~a a=~a\n" fn x a)
(cond
((atom fn)
(debug "(atom fn)=~a\n" (atom fn))
(cond
((eq fn CAR) (caar x))
((eq fn CDR) (cdar x))
((eq fn CONS) (cons (car x) (cadr x)))
((eq fn ATOM) (atom (car x)))
((eq fn EQ) (eq (car x) (cadr x)))
(#t (apply (eval fn a) x a))))
((eq (car fn) LAMBDA) (eval (caddr fn) (pairlis (cadr fn) x a)))
((eq (car fn) LABEL) (apply (caddr fn) x (cons (cons (cadr fn)
(caddr fn)) a)))))
(define (eval e a)
(debug "eval e=~a a=~a\n" e a)
(debug "eval (atom ~a)=~a\n" e (atom e))
(cond
((atom e) (cdr (assoc e a)))
((atom (car e))
(cond
((eq (car e) QUOTE) (cadr e))
((eq (car e) COND) (evcon (cdr e) a))
(#t (apply (car e) (evlis (cdr e) a) a))))
(#t (apply (car e) (evlis (cdr e) a) a))))
(define (evcon c a)
(debug "evcon c=~a a=~a\n" c a)
(cond
((eval (caar c) a) (eval (cadar c) a))
(#t (evcon (cdr c) a))))
(define (evlis m a)
(debug "evlis m=~a a=~a\n" m a)
(cond
((null m) NIL)
(#t (cons (eval (car m) a) (evlis (cdr m) a)))))
(define (main arguments)
(stdout "Hello scm\n")
(guile:display (eval 0 '((0 . 0) (1 . 1))))
(guile:newline)
(guile:display (eval 1 '((0 . 0) (1 . 1))))
(guile:newline)
(guile:display (eval '(car '(0 1)) '((0 . 0) (1 . 1))))
(guile:newline)
(guile:display (eval '(cdr '(0 1)) '((0 . 0) (1 . 1))))
(guile:newline)
(guile:display (apply 'cons '(0 1) '((0 . 0) (1 . 1))))
(guile:newline)
(guile:display (eval '(cons 0 1) '((0 . 0) (1 . 1))))
(guile:newline)
(guile:display (apply '(lambda (x y) (cons x y)) '(0 1) '((0 . 0) (1 . 1))))
(guile:newline)
(guile:display (eval '((label fun (lambda (x) x)) 2 2) '((2 . 2))))
(guile:newline))
(guile:module-define! (guile:resolve-interface '(scm)) 'main main)