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)