mes/guile/mes.scm

#! /bin/sh
# -*-scheme-*-
exec guile -L $(pwd) -e '(mes)' -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 (mes)
  #:export (main))

(let ((guile (resolve-interface
              '(guile)
              #:select `(
                         ;; Debugging
                         apply
                         cons*
                         current-module
                         display
                         eof-object?
                         eval
                         exit
                         force-output
                         format
                         list
                         map
                         newline
                         read
                         
                         ;; Guile admin
                         module-define!
                         resolve-interface
                         
                         ;; PRIMITIVE BUILTINS
                         car
                         cdr
                         cons
                         eq?
                         null?
                         pair?
                         *unspecified*
                         
                         ;; READER
                         char->integer
                         integer->char
                         
                         ;; non-primitive BUILTINS
                         char?
                         number?
                         procedure?
                         string?
                         <
                         -
                         )
              #:renamer (symbol-prefix-proc 'guile:)))
      (guile-2.0 (resolve-interface '(guile) #:select '(define)))
      (guile-2.2 (resolve-interface '(guile) #:select '(quasiquote unquote)))
      (ports (resolve-interface
              (if (equal? (effective-version) "2.0")'(guile) '(ice-9 ports))
                  #:select '(
                             ;; Debugging
                             current-error-port
                             current-output-port
                             
                             ;; READER
                             ;;peek-char
                             read-char
                             unread-char)
                  #:renamer (symbol-prefix-proc 'guile:))))
  (set-current-module
   (make-module 10 `(,guile ,guile-2.0 ,guile-2.2 ,ports))))

(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 pair? guile:pair?)
(define builtin? guile:procedure?)
(define char? guile:char?)
(define number? guile:number?)
(define string? guile:number?)
(define call guile:apply)
(define (peek-byte)
  (unread-byte (read-byte)))
;;(define peek-byte guile:peek-char)
(define (read-byte)
  (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)

(define (char->integer c)
  (if (guile:eof-object? c) -1 (guile:char->integer c)))

(include "mes.mes")
;; guile-2.2 only, guile-2.0 has no include?
(include "reader.mes")

(define (append2 x y)
  (cond ((null? x) y)
        (#t (cons (car x) (append2 (cdr x) y)))))

;; READER: TODO lookup
(define (read)
  (let ((x (guile:read)))
    (if (guile:eof-object? x) '()
        x)))

(define (lookup-macro e a)
  #f)

(define environment
  (guile:map
   (lambda (x) (cons (car x) (guile:eval (cdr x) (guile:current-module))))
   '(
    ((guile:list) . (guile:list))
    (#t . #t)
    (#f . #f)
    
    (*unspecified* . guile:*unspecified*)

    (atom? . atom?)
    (car . car)
    (cdr . cdr)
    (cons . cons)
    ;; (cond . evcon)
    (eq? . eq?)

    (null? . null?)
    (pair? . guile:pair?)
    ;;(quote . quote)

    (evlis-env . evlis-env)
    (evcon . evcon)
    (pairlis . pairlis)
    (assq . assq)
    (assq-ref-env . assq-ref-env)

    (eval-env . eval-env)
    (apply-env . apply-env)

    (read . read)
    (display . guile:display)
    (newline . guile:newline)

    (builtin? . builtin?)
    (number? . number?)
    (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)

    (append2 . append2)
    (exit . guile:exit)

    (*macro* . (guile:list))
    (*dot* . '.)

    ;;
    (stderr . stderr))))

(define (main arguments)
  (let ((program (read-input-file)))
    ;;(stderr "program:~a\n" program)
    (guile:display (eval-env program environment)))
  (guile:newline))

(guile:module-define! (guile:resolve-interface '(mes)) 'main main)