boot.mes: generate from mes.mes, scm.mes, test.mes.
This commit is contained in:
Jan Nieuwenhuizen
parent
0eb32de9c7
commit
1513c0d5fb
4
.gitignore
vendored
4
.gitignore
vendored
|
|
@ -1,6 +1,6 @@
|
||||||
*~
|
|
||||||
*-
|
*-
|
||||||
*.go
|
*.go
|
||||||
*.o
|
*.o
|
||||||
|
*~
|
||||||
|
/boot.mes
|
||||||
/mes
|
/mes
|
||||||
|
|
||||||
|
|
|
||||||
12
GNUmakefile
12
GNUmakefile
|
|
@ -4,14 +4,18 @@ CFLAGS=-std=c99 -O3 -finline-functions
|
||||||
|
|
||||||
default: all
|
default: all
|
||||||
|
|
||||||
all: mes
|
all: mes boot.mes
|
||||||
|
|
||||||
check: all
|
check: all
|
||||||
./mes.test
|
./mes.test
|
||||||
./mes.test ./mes
|
./mes.test ./mes
|
||||||
# ./mes < boot.mes
|
./mes < test.mes
|
||||||
# ./mes < scm.mes
|
|
||||||
# ./mes.scm < scm.mes
|
boot.mes: mes.mes scm.mes test.mes
|
||||||
|
cat $^ > $@
|
||||||
|
|
||||||
boot: all
|
boot: all
|
||||||
./mes < boot.mes
|
./mes < boot.mes
|
||||||
|
|
||||||
|
run: all
|
||||||
|
./mes < test.mes
|
||||||
|
|
|
||||||
339
boot.mes
339
boot.mes
|
|
@ -1,339 +0,0 @@
|
||||||
#! /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
|
|
||||||
|
|
||||||
;; 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)
|
|
||||||
;; ((atom x) (cons (cons x y) 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)
|
|
||||||
;; (display 'mes-evlis:)
|
|
||||||
;; (display m)
|
|
||||||
;; (newline)
|
|
||||||
(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)
|
|
||||||
(cond
|
|
||||||
((atom fn)
|
|
||||||
(cond
|
|
||||||
((builtin fn)
|
|
||||||
(call fn x))
|
|
||||||
(#t (apply (eval fn a) x a))))
|
|
||||||
((eq (car fn) 'lambda)
|
|
||||||
(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)
|
|
||||||
(cond
|
|
||||||
((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))
|
|
||||||
((pair (assoc (car e) (cdr (assoc '*macro* a))))
|
|
||||||
(c:eval
|
|
||||||
(c:apply
|
|
||||||
(cdr (assoc (car e) (cdr (assoc '*macro* a))))
|
|
||||||
(cdr e)
|
|
||||||
a)
|
|
||||||
a))
|
|
||||||
(#t (apply (car e) (evlis (cdr e) a) a))))
|
|
||||||
(#t (apply (car e) (evlis (cdr e) a) a))))
|
|
||||||
|
|
||||||
;; readenv et al works, but slows down dramatically
|
|
||||||
(define (DISABLED-readenv a)
|
|
||||||
(readword (getchar) '() a))
|
|
||||||
|
|
||||||
(define (readword c w a)
|
|
||||||
(display 'mes-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))
|
|
||||||
;; DOT ((eq w '(*dot*)) (car (readword (getchar) '() 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 'mes-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))
|
|
||||||
((atom e)
|
|
||||||
(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
|
|
||||||
|
|
||||||
(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 y)
|
|
||||||
(#t #f)))
|
|
||||||
|
|
||||||
(define-macro (or x y)
|
|
||||||
(cond (x x)
|
|
||||||
(#t y)))
|
|
||||||
|
|
||||||
;; EOF2
|
|
||||||
;; EOF
|
|
||||||
;; EOF2
|
|
||||||
|
|
||||||
(display 'and-0-1:)
|
|
||||||
(display (and 0 1))
|
|
||||||
(newline)
|
|
||||||
(display 'and-#f-2:)
|
|
||||||
(display (and #f 2))
|
|
||||||
(newline)
|
|
||||||
|
|
||||||
(display 'or-0-1:)
|
|
||||||
(display (or 0 1))
|
|
||||||
(newline)
|
|
||||||
(display 'or-#f-2:)
|
|
||||||
(display (or #f 2))
|
|
||||||
(newline)
|
|
||||||
|
|
||||||
(define (split-params bindings params)
|
|
||||||
(cond ((null bindings) params)
|
|
||||||
(#t (split-params (cdr bindings)
|
|
||||||
(append params (cons (caar bindings) '()))))))
|
|
||||||
|
|
||||||
(define (split-values bindings values)
|
|
||||||
(cond ((null bindings) values)
|
|
||||||
(#t (split-values (cdr bindings)
|
|
||||||
(append values (cdar bindings) '())))))
|
|
||||||
|
|
||||||
(define-macro (let1 bindings body)
|
|
||||||
(cons (cons 'lambda (cons (split-params bindings '()) (cons body '())))
|
|
||||||
(split-values bindings '())))
|
|
||||||
|
|
||||||
(let1 ((a 3)
|
|
||||||
(b 4))
|
|
||||||
((lambda ()
|
|
||||||
(display 'let-a:3-b:4)
|
|
||||||
(newline)
|
|
||||||
(display 'a:)
|
|
||||||
(display a)
|
|
||||||
(newline)
|
|
||||||
(display 'b:)
|
|
||||||
(display b)
|
|
||||||
(newline))))
|
|
||||||
|
|
||||||
(display 'let1-dun)
|
|
||||||
(newline)
|
|
||||||
|
|
||||||
(define-macro (let bindings . body)
|
|
||||||
(cons (cons 'lambda (cons (split-params bindings '()) body))
|
|
||||||
(split-values bindings '())))
|
|
||||||
|
|
||||||
(let ((p 5)
|
|
||||||
(q 6))
|
|
||||||
(display 'let-p:3-q:4)
|
|
||||||
(newline)
|
|
||||||
(display 'p:)
|
|
||||||
(display p)
|
|
||||||
(newline)
|
|
||||||
(display 'q:)
|
|
||||||
(display q)
|
|
||||||
(newline))
|
|
||||||
|
|
||||||
|
|
||||||
(display
|
|
||||||
(let ((p 5)
|
|
||||||
(q 6))
|
|
||||||
(display 'hallo)
|
|
||||||
(display p)
|
|
||||||
(display 'daar)
|
|
||||||
(display q)
|
|
||||||
(display 'dan)))
|
|
||||||
|
|
||||||
(newline)
|
|
||||||
(display 'let-dun)
|
|
||||||
(newline)
|
|
||||||
|
|
||||||
'()
|
|
||||||
262
mes.mes
262
mes.mes
|
|
@ -1,107 +1,61 @@
|
||||||
;; -*-scheme-*-
|
;;; -*-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
|
;;; Mes --- Maxwell Equations of Software
|
||||||
(define (pairlis x y a)
|
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
|
||||||
(debug "pairlis x=~a y=~a a=~a\n" x y a)
|
;;;
|
||||||
(cond
|
;;; mes.mes: This file is part of Mes.
|
||||||
((null x) a)
|
;;;
|
||||||
(#t (cons (cons (car x) (car y))
|
;;; Mes is free software; you can redistribute it and/or modify it
|
||||||
(pairlis (cdr x) (cdr y) a)))))
|
;;; 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/>.
|
||||||
|
|
||||||
(define (assoc x a)
|
;; The Maxwell Equations of Software -- John McCarthy page 13
|
||||||
;;(stderr "assoc x=~a\n" x)
|
;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
|
||||||
(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 (caar x) (car (car x)))
|
||||||
(define (eval-quote fn x)
|
;; (define (cadr x) (car (cdr x)))
|
||||||
(debug "eval-quote fn=~a x=~a" fn x)
|
;; (define (cdar x) (cdr (car x)))
|
||||||
(apply fn 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))))
|
||||||
|
|
||||||
(define (apply fn x a)
|
;; ;; Page 12
|
||||||
(debug "apply fn=~a x=~a a=~a\n" fn x a)
|
;; (define (pairlis x y a)
|
||||||
(cond
|
;; ;;(debug "pairlis x=~a y=~a a=~a\n" x y a)
|
||||||
((atom fn)
|
;; (cond
|
||||||
(debug "(atom fn)=~a\n" (atom fn))
|
;; ((null x) a)
|
||||||
(cond
|
;; ((atom x) (cons (cons x y) a))
|
||||||
;; John McCarthy LISP 1.5
|
;; (#t (cons (cons (car x) (car y))
|
||||||
;; ((eq fn CAR) (caar x))
|
;; (pairlis (cdr x) (cdr y) a)))))
|
||||||
;; ((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) '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)
|
;; (define (assoc x a)
|
||||||
(debug "eval e=~a a=~a\n" e a)
|
;; ;;(stderr "assoc x=~a\n" x)
|
||||||
;;(debug "eval (atom ~a)=~a\n" e (atom e))
|
;; ;;(debug "assoc x=~a a=~a\n" x a)
|
||||||
(cond
|
;; (cond
|
||||||
;;((and (stderr "NUMBER? ~a ==> ~a\n" e (number e)) #f))
|
;; ((null a) #f)
|
||||||
((number e) e)
|
;; ((eq (caar a) x) (car a))
|
||||||
;; error: extra
|
;; (#t (assoc x (cdr a)))))
|
||||||
((atom e) (cond ((eq (assoc e a) #f)
|
|
||||||
(stderr "no such symbol: ~a\n" e)
|
;; ;; Page 13
|
||||||
(guile:exit 1))
|
;; (define (eval-quote fn x)
|
||||||
(#t (cdr (assoc e a)))))
|
;; ;(debug "eval-quote fn=~a x=~a" fn x)
|
||||||
((atom e) (cdr (assoc e a)))
|
;; (apply fn x '()))
|
||||||
((builtin e) e)
|
|
||||||
;;((and (stderr "eeee: ~a\n" e) #f))
|
|
||||||
((atom (car e))
|
|
||||||
(cond
|
|
||||||
((eq (car e) 'quote) (cadr e))
|
|
||||||
((eq (car e) 'cond) (evcon (cdr e) a))
|
|
||||||
;; EXTRA: macro expandszor
|
|
||||||
;;((and (stderr "2eeee: ~a\n" (cdr (assoc '*macro* a))) #f))
|
|
||||||
(;;;(pair (assoc (car e) (cdr (assoc '*macro* a))))
|
|
||||||
#f
|
|
||||||
;;(stderr "macro: ~a\n" (assoc (car e) (cdr (assoc '*macro* a))))
|
|
||||||
(stderr "apply: ~a ~a\n"
|
|
||||||
`(cons 'lambda (cdr (cdr
|
|
||||||
,(assoc (car e) (cdr (assoc '*macro* a)))
|
|
||||||
)))
|
|
||||||
`(evlis ,(cddr e) a)
|
|
||||||
;;'(evlist foobar)
|
|
||||||
)
|
|
||||||
(eval (apply
|
|
||||||
`(cons 'lambda (cdr (cdr
|
|
||||||
,(assoc (car e) (cdr (assoc '*macro* a)))
|
|
||||||
)))
|
|
||||||
`(evlis ,(cddr e) a)
|
|
||||||
a)
|
|
||||||
a))
|
|
||||||
(#t (apply (car e) (evlis (cdr e) a) a))))
|
|
||||||
(#t (apply (car e) (evlis (cdr e) a) a))))
|
|
||||||
|
|
||||||
(define (evcon c a)
|
(define (evcon c a)
|
||||||
(debug "evcon c=~a a=~a\n" c a)
|
;;(debug "evcon c=~a a=~a\n" c a)
|
||||||
(cond
|
(cond
|
||||||
;; single-statement cond
|
;; single-statement cond
|
||||||
;; ((eval (caar c) a) (eval (cadar c) a))
|
;; ((eval (caar c) a) (eval (cadar c) a))
|
||||||
|
|
@ -114,7 +68,119 @@
|
||||||
(#t (evcon (cdr c) a))))
|
(#t (evcon (cdr c) a))))
|
||||||
|
|
||||||
(define (evlis m a)
|
(define (evlis m a)
|
||||||
(debug "evlis m=~a a=~a\n" m a)
|
;;(debug "evlis m=~a a=~a\n" m a)
|
||||||
|
;; (display 'mes-evlis:)
|
||||||
|
;; (display m)
|
||||||
|
;; (newline)
|
||||||
(cond
|
(cond
|
||||||
((null m) '())
|
((null m) '())
|
||||||
(#t (cons (eval (car m) a) (evlis (cdr m) a)))))
|
(#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)
|
||||||
|
(cond
|
||||||
|
((atom fn)
|
||||||
|
(cond
|
||||||
|
((builtin fn)
|
||||||
|
(call fn x))
|
||||||
|
(#t (apply (eval fn a) x a))))
|
||||||
|
((eq (car fn) 'lambda)
|
||||||
|
(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)
|
||||||
|
(cond
|
||||||
|
((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))
|
||||||
|
((pair (assoc (car e) (cdr (assoc '*macro* a))))
|
||||||
|
(c:eval
|
||||||
|
(c:apply
|
||||||
|
(cdr (assoc (car e) (cdr (assoc '*macro* a))))
|
||||||
|
(cdr e)
|
||||||
|
a)
|
||||||
|
a))
|
||||||
|
(#t (apply (car e) (evlis (cdr e) a) a))))
|
||||||
|
(#t (apply (car e) (evlis (cdr e) a) a))))
|
||||||
|
|
||||||
|
;; readenv et al works, but slows down dramatically
|
||||||
|
(define (DISABLED-readenv a)
|
||||||
|
(readword (getchar) '() a))
|
||||||
|
|
||||||
|
(define (readword c w a)
|
||||||
|
(display 'mes-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))
|
||||||
|
;; DOT ((eq w '(*dot*)) (car (readword (getchar) '() 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 'mes-readlis:)
|
||||||
|
(newline)
|
||||||
|
(cond ((eq (peekchar) 41) ;; )
|
||||||
|
(getchar)
|
||||||
|
'())
|
||||||
|
;; TODO *dot*
|
||||||
|
(#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)))))
|
||||||
|
|
|
||||||
73
scm.mes
73
scm.mes
|
|
@ -1,12 +1,9 @@
|
||||||
#! /bin/sh
|
;;; -*-scheme-*-
|
||||||
# -*-scheme-*-
|
|
||||||
exec ./mes "$@" < "$0"
|
|
||||||
!#
|
|
||||||
|
|
||||||
;;; Mes --- Maxwell Equations of Software
|
;;; Mes --- Maxwell Equations of Software
|
||||||
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
|
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
|
||||||
;;;
|
;;;
|
||||||
;;; This file is part of Mes.
|
;;; scm.mes: This file is part of Mes.
|
||||||
;;;
|
;;;
|
||||||
;;; Mes is free software; you can redistribute it and/or modify it
|
;;; Mes is free software; you can redistribute it and/or modify it
|
||||||
;;; under the terms of the GNU General Public License as published by
|
;;; under the terms of the GNU General Public License as published by
|
||||||
|
|
@ -24,44 +21,36 @@ exec ./mes "$@" < "$0"
|
||||||
;; The Maxwell Equations of Software -- John McCarthy page 13
|
;; The Maxwell Equations of Software -- John McCarthy page 13
|
||||||
;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
|
;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
|
||||||
|
|
||||||
(display 'boo)
|
(define (scm-define x a)
|
||||||
(newline)
|
(cond ((atom (cadr x)) (cons (cadr x) (eval (caddr x) a)))
|
||||||
|
(#t (cons (caadr x) (cons 'lambda (cons (cdadr x) (cddr x)))))))
|
||||||
|
|
||||||
;; (display '*a*:)
|
(define (scm-define-macro x a)
|
||||||
;; (display (eval '*a* '()))
|
(cons '*macro*
|
||||||
|
(cons (cons (caadr e) (cons 'lambda (cons (cdadr e) (cddr e))))
|
||||||
|
(cdr (assoc '*macro* a)))))
|
||||||
|
|
||||||
|
(define (loop2 r e a)
|
||||||
|
;; (display '____loop2)
|
||||||
;; (newline)
|
;; (newline)
|
||||||
|
;; (display 'e:)
|
||||||
|
;; (display e)
|
||||||
|
;; (newline)
|
||||||
|
(cond ((null e) r)
|
||||||
|
((eq e 'EOF2)
|
||||||
|
(display 'loop2-exiting...)
|
||||||
|
(newline))
|
||||||
|
((atom e)
|
||||||
|
(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)))
|
||||||
|
|
||||||
(define (+ x y) (- x (- 0 y)))
|
(#t (loop2 (eval e a) (readenv a) a))
|
||||||
|
;;(#t (loop2 ((cdr (assoc 'eval a)) e a) (readenv a) a))
|
||||||
|
))
|
||||||
|
|
||||||
(display (+ 3 4))
|
;;(display 'loop:read-loop2-exiting...)
|
||||||
(newline)
|
;;(newline)
|
||||||
|
EOF
|
||||||
(define-macro (and x y)
|
|
||||||
(cond (x y)
|
|
||||||
(#t #f)))
|
|
||||||
|
|
||||||
(define-macro (or x y)
|
|
||||||
(cond (x x)
|
|
||||||
(#t y)))
|
|
||||||
|
|
||||||
(define (split-params bindings params)
|
|
||||||
(cond ((null bindings) params)
|
|
||||||
(#t (split-params (cdr bindings)
|
|
||||||
(append params (cons (caar bindings) '()))))))
|
|
||||||
|
|
||||||
(define (split-values bindings values)
|
|
||||||
(cond ((null bindings) values)
|
|
||||||
(#t (split-values (cdr bindings)
|
|
||||||
(append values (cdar bindings) '())))))
|
|
||||||
|
|
||||||
(define-macro (let bindings body)
|
|
||||||
(cons (cons 'lambda (cons (split-params bindings '()) (cons body '())))
|
|
||||||
(split-values bindings '())))
|
|
||||||
|
|
||||||
(display 'and-0-1:)
|
|
||||||
(display (and 0 1))
|
|
||||||
(newline)
|
|
||||||
|
|
||||||
(display 'or-#f-1:)
|
|
||||||
(display (or #f 2))
|
|
||||||
(newline)
|
|
||||||
|
|
|
||||||
127
test.mes
Normal file
127
test.mes
Normal file
|
|
@ -0,0 +1,127 @@
|
||||||
|
;;; -*-scheme-*-
|
||||||
|
|
||||||
|
;;; Mes --- Maxwell Equations of Software
|
||||||
|
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
|
||||||
|
;;;
|
||||||
|
;;; test.mes: 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 Software -- John McCarthy page 13
|
||||||
|
;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
|
||||||
|
|
||||||
|
(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 y)
|
||||||
|
(#t #f)))
|
||||||
|
|
||||||
|
(define-macro (or x y)
|
||||||
|
(cond (x x)
|
||||||
|
(#t y)))
|
||||||
|
|
||||||
|
;; EOF2
|
||||||
|
;; EOF
|
||||||
|
;; EOF2
|
||||||
|
|
||||||
|
(display 'and-0-1:)
|
||||||
|
(display (and 0 1))
|
||||||
|
(newline)
|
||||||
|
(display 'and-#f-2:)
|
||||||
|
(display (and #f 2))
|
||||||
|
(newline)
|
||||||
|
|
||||||
|
(display 'or-0-1:)
|
||||||
|
(display (or 0 1))
|
||||||
|
(newline)
|
||||||
|
(display 'or-#f-2:)
|
||||||
|
(display (or #f 2))
|
||||||
|
(newline)
|
||||||
|
|
||||||
|
(define (split-params bindings params)
|
||||||
|
(cond ((null bindings) params)
|
||||||
|
(#t (split-params (cdr bindings)
|
||||||
|
(append params (cons (caar bindings) '()))))))
|
||||||
|
|
||||||
|
(define (split-values bindings values)
|
||||||
|
(cond ((null bindings) values)
|
||||||
|
(#t (split-values (cdr bindings)
|
||||||
|
(append values (cdar bindings) '())))))
|
||||||
|
|
||||||
|
(define-macro (let1 bindings body)
|
||||||
|
(cons (cons 'lambda (cons (split-params bindings '()) (cons body '())))
|
||||||
|
(split-values bindings '())))
|
||||||
|
|
||||||
|
(let1 ((a 3)
|
||||||
|
(b 4))
|
||||||
|
((lambda ()
|
||||||
|
(display 'let-a:3-b:4)
|
||||||
|
(newline)
|
||||||
|
(display 'a:)
|
||||||
|
(display a)
|
||||||
|
(newline)
|
||||||
|
(display 'b:)
|
||||||
|
(display b)
|
||||||
|
(newline))))
|
||||||
|
|
||||||
|
(display 'let1-dun)
|
||||||
|
(newline)
|
||||||
|
|
||||||
|
(define-macro (let bindings . body)
|
||||||
|
(cons (cons 'lambda (cons (split-params bindings '()) body))
|
||||||
|
(split-values bindings '())))
|
||||||
|
|
||||||
|
(let ((p 5)
|
||||||
|
(q 6))
|
||||||
|
(display 'let-p:3-q:4)
|
||||||
|
(newline)
|
||||||
|
(display 'p:)
|
||||||
|
(display p)
|
||||||
|
(newline)
|
||||||
|
(display 'q:)
|
||||||
|
(display q)
|
||||||
|
(newline))
|
||||||
|
|
||||||
|
|
||||||
|
(display
|
||||||
|
(let ((p 5)
|
||||||
|
(q 6))
|
||||||
|
(display 'hallo)
|
||||||
|
(display p)
|
||||||
|
(display 'daar)
|
||||||
|
(display q)
|
||||||
|
(display 'dan)))
|
||||||
|
|
||||||
|
(newline)
|
||||||
|
(display 'let-dun)
|
||||||
|
(newline)
|
||||||
|
|
||||||
|
'()
|
||||||
Loading…
Reference in a new issue