370 lines
10 KiB
Scheme
370 lines
10 KiB
Scheme
#! /bin/sh
|
|
# -*-scheme-*-
|
|
exec ./mes "$@" < "$0"
|
|
!#
|
|
|
|
;;; Mes --- Maxwell Equations of Software
|
|
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
|
|
;;;
|
|
;;; This file is part of Mes.
|
|
;;;
|
|
;;; 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 programming -- John McCarthy page 13
|
|
;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
|
|
|
|
;; ((label loop
|
|
;; (lambda (r e a)
|
|
;; (cond ((null e) a)
|
|
;; ((eq e 'exit)
|
|
;; (display 'loop:exiting)
|
|
;; (newline)
|
|
;; (apply 'loop2 (cons #t (cons #t (cons a '()))) a))
|
|
;; ((atom e) (loop (eval e a) (readenv a) a))
|
|
;; ((eq (car e) 'define)
|
|
;; (loop *unspecified*
|
|
;; (readenv a)
|
|
;; (cons
|
|
;; (cond ((atom (cadr e))
|
|
;; (cons (cadr e) (eval (caddr e) a)))
|
|
;; (#t
|
|
;; (newline)
|
|
;; (cons (caadr e)
|
|
;; (cons 'lambda
|
|
;; (cons (cdadr e) (cddr e))))))
|
|
;; a)))
|
|
;; (#t (loop (eval e a) (readenv a) a)))))
|
|
;; *unspecified* (readenv '()) '((*macro*)))
|
|
|
|
(display 'loop-reading...)
|
|
(newline)
|
|
|
|
;; loop adds definitions of mes.mes to current-environment
|
|
;;mes.mes
|
|
|
|
;; ;; -*-scheme-*-
|
|
;; ;;
|
|
;; (define (caar x) (car (car x)))
|
|
;; (define (cadr x) (car (cdr x)))
|
|
;; (define (cdar x) (cdr (car x)))
|
|
;; (define (cddr x) (cdr (cdr x)))
|
|
;; (define (caadr x) (car (car (cdr x))))
|
|
;; (define (caddr x) (car (cdr (cdr x))))
|
|
;; (define (cddar x) (cdr (cdr (car x))))
|
|
;; (define (cdadr x) (cdr (car (cdr x))))
|
|
;; (define (cadar x) (car (cdr (car x))))
|
|
;; (define (cdddr x) (cdr (cdr (cdr 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)
|
|
;; ;;(stderr "assoc x=~a\n" x)
|
|
;; ;;(debug "assoc x=~a a=~a\n" x a)
|
|
;; (cond
|
|
;; ((null a) #f)
|
|
;; ((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 '()))
|
|
|
|
(define (evcon c a)
|
|
;;(debug "evcon c=~a a=~a\n" c a)
|
|
(cond
|
|
;; single-statement cond
|
|
;; ((eval (caar c) a) (eval (cadar c) a))
|
|
((eval (caar c) a)
|
|
(cond ((null (cddar c)) (eval (cadar c) a))
|
|
(#t (eval (cadar c) a)
|
|
(evcon
|
|
(cons (cons #t (cddar c)) '())
|
|
a))))
|
|
(#t (evcon (cdr c) a))))
|
|
|
|
(define (evlis m a)
|
|
;;(debug "evlis m=~a a=~a\n" m a)
|
|
(cond
|
|
((null m) '())
|
|
(#t (cons (eval (car m) a) (evlis (cdr m) a)))))
|
|
|
|
|
|
(define (apply fn x a)
|
|
;; (display 'mes-apply:)
|
|
;; (newline)
|
|
;; (display 'fn:)
|
|
;; (display fn)
|
|
;; (newline)
|
|
;; (display 'builtin:)
|
|
;; (display (builtin fn))
|
|
;; (newline)
|
|
;; (display 'x:)
|
|
;; (display x)
|
|
;; (newline)
|
|
;;(debug "apply fn=~a x=~a a=~a\n" fn x a)
|
|
(cond
|
|
((atom fn)
|
|
;;(debug "(atom fn)=~a\n" (atom fn))
|
|
(cond
|
|
;; John McCarthy LISP 1.5
|
|
;; ((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)))
|
|
((builtin fn)
|
|
(call fn x))
|
|
(#t (apply (eval fn a) x a))))
|
|
;; John McCarthy LISP 1.5
|
|
((eq (car fn) 'single-line-LAMBDA) (eval (caddr fn) (pairlis (cadr fn) x a)))
|
|
((eq (car fn) 'lambda)
|
|
;; (CDDR fn) all eval
|
|
(cond ((null (cdr (cddr fn)))
|
|
(eval (caddr fn) (pairlis (cadr fn) x a)))
|
|
(#t
|
|
(eval (caddr fn) (pairlis (cadr fn) x a))
|
|
(apply (cons (car fn) (cons (cadr fn) (cdddr fn)))
|
|
x
|
|
(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))
|
|
;; (display 'mes-eval:)
|
|
;; (display e)
|
|
;; (newline)
|
|
;; (display 'a:)
|
|
;; (display a)
|
|
;; (newline)
|
|
;;(display 'pair?*macro*:)
|
|
;;(display (assoc '*macro* a))
|
|
;; (display (cdr (assoc '*macro* a)))
|
|
;; (newline)
|
|
(cond
|
|
;;((and (stderr "NUMBER? ~a ==> ~a\n" e (number e)) #f))
|
|
((number e) e)
|
|
((eq e #t) #t)
|
|
((eq e #f) #f)
|
|
((atom e) (cdr (assoc e a)))
|
|
((builtin e) e)
|
|
((atom (car e))
|
|
(cond
|
|
((eq (car e) 'quote) (cadr e))
|
|
((eq (car e) 'cond) (evcon (cdr e) a))
|
|
;; no macro support:
|
|
(#t (apply (car e) (evlis (cdr e) a) a))
|
|
;; ^^^^^^^^^^^^^^^^^
|
|
(#t
|
|
(cond
|
|
;; (#t
|
|
;; (display 'could-be-macro:)
|
|
;; (display e)
|
|
;; (newline)
|
|
;; (display 'null:)
|
|
;; (display (null (cdr (assoc '*macro* a))))
|
|
;; (newline)
|
|
;; #f)
|
|
;;(#t (apply (car e) (evlis (cdr e) a) a))
|
|
((eq (assoc '*macro* a) #f)
|
|
;;(null (cdr (assoc '*macro* a)))
|
|
|
|
;; (display 'we-have-no-macros:)
|
|
;; (display e)
|
|
;; (newline)
|
|
|
|
(apply (car e) (evlis (cdr e) a) a)
|
|
)
|
|
((pair (assoc (car e) (cdr (assoc '*macro* a))))
|
|
;; (display 'expanz0r:)
|
|
;; (display (assoc (car e) (cdr (assoc '*macro* a))))
|
|
;; (newline)
|
|
;; (display 'running:)
|
|
;; (display (cdr (assoc (car e) (cdr (assoc '*macro* a)))))
|
|
;; (newline)
|
|
;; (display 'args:)
|
|
;; (display (cdr e))
|
|
;; (newline)
|
|
;; (display '==>args:)
|
|
;; (display (evlis (cdr e) a))
|
|
;; (newline)
|
|
(eval (apply
|
|
(cdr (assoc (car e) (cdr (assoc '*macro* a))))
|
|
(evlis (cdr e) a)
|
|
a)
|
|
a))
|
|
(#t (apply (car e) (evlis (cdr e) a) a))))
|
|
(#t (apply (car e) (evlis (cdr e) a) a))))
|
|
(#t (apply (car e) (evlis (cdr e) a) a))))
|
|
|
|
(define (readenv a)
|
|
(readword (getchar) '() a))
|
|
|
|
(define (readword c w a)
|
|
;; (display 'readword:)
|
|
;; (display c)
|
|
;; (newline)
|
|
(cond ((eq c -1) ;; eof
|
|
(cond ((eq w '()) '())
|
|
(#t (lookup w a))))
|
|
((eq c 10) ;; \n
|
|
(cond ((eq w '()) (readword (getchar) w a))
|
|
(#t (lookup w a))))
|
|
((eq c 32) ;; \space
|
|
(readword 10 w a))
|
|
((eq c 40) ;; (
|
|
(cond ((eq w '()) (readlis a))
|
|
(#t (ungetchar c) (lookup w a))))
|
|
((eq c 41) ;; )
|
|
(cond ((eq w '()) (ungetchar c) w)
|
|
(#t (ungetchar c) (lookup w a))))
|
|
((eq c 39) ;; '
|
|
(cond ((eq w '())
|
|
(cons (lookup (cons c '()) a)
|
|
(cons (readword (getchar) w a) '())))
|
|
(#t (ungetchar c) (lookup w a))))
|
|
((eq c 59) ;; ;
|
|
(readcomment 59)
|
|
(readword 10 w a))
|
|
(#t (readword (getchar) (append w (cons c '())) a))))
|
|
|
|
(define (readlis a)
|
|
;; (display 'readlis:)
|
|
;; (newline)
|
|
(cond ((eq (peekchar) 41) ;; )
|
|
(getchar)
|
|
'())
|
|
(#t (xcons (readlis a) (readword (getchar) '() a)))))
|
|
|
|
(define (xcons a b)
|
|
(cons b a))
|
|
|
|
(define (readcomment c)
|
|
(cond ((eq c 10) ;; \n
|
|
c)
|
|
(#t (readcomment (getchar)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; we also add helpers to make loop2 simpler
|
|
(define (scm-define x a)
|
|
(cond ((atom (cadr x)) (cons (cadr x) (eval (caddr x) a)))
|
|
(#t (cons (caadr x) (cons 'lambda (cons (cdadr x) (cddr x)))))))
|
|
|
|
(define (scm-define-macro x a)
|
|
(cons '*macro*
|
|
(cons (cons (caadr e) (cons 'lambda (cons (cdadr e) (cddr e))))
|
|
(cdr (assoc '*macro* a)))))
|
|
|
|
(define (scm-display x)
|
|
(display x))
|
|
|
|
(define (loop2 r e a)
|
|
(display '____loop2)
|
|
(newline)
|
|
(display 'e:)
|
|
(display e)
|
|
;; (newline)
|
|
(cond ((null e) r)
|
|
((eq e 'EOF2)
|
|
(display 'loop2-exiting...)
|
|
(newline))
|
|
((eq (assoc '*macro* a) #f)
|
|
(loop2 r (readenv a) (cons (cons '*macro* '()) a)))
|
|
((atom e)
|
|
;; (display 'loop2:atom)
|
|
;; (newline)
|
|
;; (display 'skipping-one-read-scm:)
|
|
;; (display (readenv a))
|
|
;; (newline)
|
|
(loop2 (eval e a) (readenv a) a)
|
|
)
|
|
((eq (car e) 'define)
|
|
(loop2 *unspecified* (readenv a) (cons (scm-define e a) a)))
|
|
((eq (car e) 'define-macro)
|
|
(loop2 *unspecified* (readenv a) (cons (scm-define-macro e a) a)))
|
|
|
|
(#t (loop2 (eval e a) (readenv a) a))
|
|
;;(#t (loop2 ((cdr (assoc 'eval a)) e a) (readenv a) a))
|
|
))
|
|
|
|
;;(display 'loop:read-loop2-exiting...)
|
|
;;(newline)
|
|
;;;EOF
|
|
|
|
;; loop2 skips one read:
|
|
'this-is-skipped-scm
|
|
|
|
(display 123)
|
|
4
|
|
(newline)
|
|
|
|
(display 'hello-display-symbol)
|
|
(newline)
|
|
|
|
(display '(0 1 2))
|
|
(newline)
|
|
|
|
(display (- 12 3))
|
|
(newline)
|
|
|
|
(define (+ x y) (- x (- 0 y)))
|
|
(display (+ 3 4))
|
|
|
|
(newline)
|
|
|
|
;; (define-macro (and x y)
|
|
;; (cond (x
|
|
;; (display 'true-inside-and:)
|
|
;; (display x)
|
|
;; (newline)
|
|
;; y)
|
|
;; (#t
|
|
;; (display 'false-inside-and:)
|
|
;; (display x)
|
|
;; #f)))
|
|
|
|
;; (define-macro (and x y)
|
|
;; (cond (x y)
|
|
;; (#t #f)))
|
|
|
|
;; (define-macro (or x y)
|
|
;; (cond (x x)
|
|
;; (#t y)))
|
|
|
|
;; (display 'and-0-1:)
|
|
;; ;; ;;(display (and 0 1))
|
|
;; (and 0 1)
|
|
;; (and 0 2)
|
|
;; (and #f 3)
|
|
;; (newline)
|
|
;; (display 'xscm-display)
|
|
;; (newline)
|
|
;; ;; ;;(eval '(display (and 0 1)) '((*macro*)))
|
|
;; (display (and 0 1))
|
|
|
|
'()
|
|
EOF2
|
|
EOF
|
|
|