guile/mes.scm

   1 #! /bin/sh
   2 # -*-scheme-*-
   3 exec guile -L $(pwd)/module -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                                 ;; PRIMITIVES
  53                                 car
  54                                 cdr
  55                                 cons
  56                                 eq?
  57                                 null?
  58                                 pair?
  59
  60                                 ;; ADDITIONAL PRIMITIVES
  61                                 number?
  62                                 procedure?
  63                                 <
  64                                 -
  65                                 )
  66                      #:renamer (symbol-prefix-proc 'guile:)))))
  67
  68 (define (logf port string . rest)
  69   (guile:apply guile:format (guile:cons* port string rest))
  70   (guile:force-output port)
  71   #t)
  72
  73 (define (stderr string . rest)
  74   (guile:apply logf (guile:cons* (guile:current-error-port) string rest)))
  75
  76 (define (stdout string . rest)
  77   (guile:apply logf (guile:cons* (guile:current-output-port) string rest)))
  78
  79 (define (debug . x) #t)
  80 ;;(define debug stderr)
  81
  82 ;; TODO
  83 (define (atom? x)
  84   (cond
  85    ((guile:pair? x) #f)
  86    ((guile:null? x) #f)
  87    (#t x)))
  88
  89 ;; PRIMITIVES
  90 (define car guile:car)
  91 (define cdr guile:cdr)
  92 (define cons guile:cons)
  93 (define eq? guile:eq?)
  94 (define null? guile:null?)
  95 (define pair? guile:pair?)
  96 (define builtin? guile:procedure?)
  97 (define number? guile:number?)
  98 (define call guile:apply)
  99
 100 (include-from-path "mes/mes.mes")
 101
 102 (define (pairlis x y a)
 103   ;;(debug "pairlis x=~a y=~a a=~a\n" x y a)
 104   (cond
 105    ((null? x) a)
 106    ((atom? x) (cons (cons x y) a))
 107    (#t (cons (cons (car x) (car y))
 108              (pairlis (cdr x) (cdr y) a)))))
 109
 110 (define (assq x a)
 111   ;;(stderr "assq x=~a\n" x)
 112   ;;(debug "assq x=~a a=~a\n" x a)
 113   (cond
 114    ((null? a) #f)
 115    ((eq? (caar a) x) (car a))
 116    (#t (assq x (cdr a)))))
 117
 118 (define (append x y)
 119   (cond ((null? x) y)
 120         (#t (cons (car x) (append (cdr x) y)))))
 121
 122 (define (eval-environment e a)
 123   (eval e (append a environment)))
 124
 125 (define (apply-environment fn e a)
 126   (apply-env fn e (append a environment)))
 127
 128 (define (readenv a)
 129   (let ((x (guile:read)))
 130     (if (guile:eof-object? x) '()
 131         x)))
 132
 133 (define environment
 134   `(
 135     (() . ())
 136     (#t . #t)
 137     (#f . #f)
 138
 139     (*unspecified* . ,*unspecified*)
 140
 141     (atom? . ,atom?)
 142     (car . ,car)
 143     (cdr . ,cdr)
 144     (cons . ,cons)
 145     (cond . ,evcon)
 146     (eq? . ,eq?)
 147
 148     (null? . ,null?)
 149     (pair? . ,guile:pair?)
 150     ;;(quote . ,quote)
 151
 152     (evlis . ,evlis)
 153     (evcon . ,evcon)
 154     (pairlis . ,pairlis)
 155     (assq . ,assq)
 156
 157     (eval . ,eval-environment)
 158     (apply-env . ,apply-environment)
 159
 160     (readenv . ,readenv)
 161     (display . ,guile:display)
 162     (newline . ,guile:newline)
 163
 164     (builtin? . ,builtin?)
 165     (number? . ,number?)
 166     (call . ,call)
 167
 168     (< . ,guile:<)
 169     (- . ,guile:-)
 170
 171     ;; DERIVED
 172     (caar . ,caar)
 173     (cadr . ,cadr)
 174     (cdar . ,cdar)
 175     (cddr . ,cddr)
 176     (caadr . ,caadr)
 177     (caddr . ,caddr)
 178     (cdadr . ,cdadr)
 179     (cadar . ,cadar)
 180     (cddar . ,cddar)
 181     (cdddr . ,cdddr)
 182
 183     (append . ,append)
 184     (exit . ,guile:exit)
 185
 186     (*macro* . ())
 187
 188     ;;
 189     (stderr . ,stderr)))
 190
 191 (define (mes-define-lambda x a)
 192   (cons (caadr x) (cons 'lambda (cons (cdadr x) (cddr x)))))
 193
 194 (define (mes-define x a)
 195   (if (atom? (cadr x))
 196       (cons (cadr x) (eval (caddr x) a))
 197       (mes-define-lambda x a)))
 198
 199 (define (mes-define-macro x a)
 200   (cons '*macro*
 201         (cons (mes-define-lambda x a)
 202               (cdr (assq '*macro* a)))))
 203
 204 (define (loop r e a)
 205   (cond ((null? e) r)
 206         ((eq? e 'exit)
 207          (apply-env (cdr (assq 'loop a))
 208                     (cons *unspecified* (cons #t (cons a '())))
 209                     a))
 210         ((atom? e) (loop (eval e a) (readenv a) a))
 211         ((eq? (car e) 'define)
 212          (loop *unspecified* (readenv a) (cons (mes-define e a) a)))
 213         ((eq? (car e) 'define-macro)
 214          (loop *unspecified* (readenv a) (cons (mes-define-macro e a) a)))
 215         (#t (loop (eval e a) (readenv a) a))))
 216
 217 (define (main arguments)
 218   (let ((a (append environment `((*a* . ,environment)))))
 219     ;;(guile:display (eval (readenv a) a))
 220     (guile:display (loop *unspecified* (readenv a) a))
 221     )
 222   (guile:newline))
 223
 224 (guile:module-define! (guile:resolve-interface '(mes)) 'main main)