From 1513c0d5fb7e5984c932f144fa1e91611cf41fc3 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 9 Jul 2016 13:23:58 +0200 Subject: [PATCH] boot.mes: generate from mes.mes, scm.mes, test.mes. --- .gitignore | 4 +- GNUmakefile | 12 +- boot.mes | 339 ---------------------------------------------------- mes.mes | 262 +++++++++++++++++++++++++--------------- scm.mes | 73 +++++------ test.mes | 127 ++++++++++++++++++++ 6 files changed, 332 insertions(+), 485 deletions(-) delete mode 100644 boot.mes create mode 100644 test.mes diff --git a/.gitignore b/.gitignore index 71a427fd..a0037215 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,6 @@ -*~ *- *.go *.o +*~ +/boot.mes /mes - diff --git a/GNUmakefile b/GNUmakefile index 5271407c..739b5973 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -4,14 +4,18 @@ CFLAGS=-std=c99 -O3 -finline-functions default: all -all: mes +all: mes boot.mes check: all ./mes.test ./mes.test ./mes -# ./mes < boot.mes -# ./mes < scm.mes -# ./mes.scm < scm.mes + ./mes < test.mes + +boot.mes: mes.mes scm.mes test.mes + cat $^ > $@ boot: all ./mes < boot.mes + +run: all + ./mes < test.mes diff --git a/boot.mes b/boot.mes deleted file mode 100644 index 01af3303..00000000 --- a/boot.mes +++ /dev/null @@ -1,339 +0,0 @@ -#! /bin/sh -# -*-scheme-*- -exec ./mes "$@" < "$0" -!# - -;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2016 Jan Nieuwenhuizen -;;; -;;; 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 . - -;; 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) - -'() diff --git a/mes.mes b/mes.mes index 7b0c02a5..9911546c 100644 --- a/mes.mes +++ b/mes.mes @@ -1,107 +1,61 @@ -;; -*-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)))) +;;; -*-scheme-*- -;; 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))))) +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016 Jan Nieuwenhuizen +;;; +;;; mes.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 . -(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))))) +;; The Maxwell Equations of Software -- John McCarthy page 13 +;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf -;; Page 13 -(define (eval-quote fn x) - (debug "eval-quote fn=~a x=~a" fn x) - (apply fn x '())) +;; (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)))) -(define (apply fn x a) - (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) '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))))) +;; ;; 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 (eval e a) - (debug "eval e=~a a=~a\n" e a) - ;;(debug "eval (atom ~a)=~a\n" e (atom e)) - (cond - ;;((and (stderr "NUMBER? ~a ==> ~a\n" e (number e)) #f)) - ((number e) e) - ;; error: extra - ((atom e) (cond ((eq (assoc e a) #f) - (stderr "no such symbol: ~a\n" e) - (guile:exit 1)) - (#t (cdr (assoc e a))))) - ((atom e) (cdr (assoc e a))) - ((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 (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) + ;;(debug "evcon c=~a a=~a\n" c a) (cond ;; single-statement cond ;; ((eval (caar c) a) (eval (cadar c) a)) @@ -114,7 +68,119 @@ (#t (evcon (cdr c) 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 ((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) + '()) + ;; 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))))) diff --git a/scm.mes b/scm.mes index 4115b586..03ea9002 100755 --- a/scm.mes +++ b/scm.mes @@ -1,12 +1,9 @@ -#! /bin/sh -# -*-scheme-*- -exec ./mes "$@" < "$0" -!# +;;; -*-scheme-*- ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; 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 ;;; 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 ;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf -(display 'boo) -(newline) +(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))))))) -;; (display '*a*:) -;; (display (eval '*a* '())) -;; (newline) +(define (scm-define-macro x a) + (cons '*macro* + (cons (cons (caadr e) (cons 'lambda (cons (cdadr e) (cddr e)))) + (cdr (assoc '*macro* a))))) -(define (+ x y) (- x (- 0 y))) +(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))) -(display (+ 3 4)) -(newline) + (#t (loop2 (eval e a) (readenv a) a)) + ;;(#t (loop2 ((cdr (assoc 'eval a)) e a) (readenv a) a)) + )) -(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) +;;(display 'loop:read-loop2-exiting...) +;;(newline) +EOF diff --git a/test.mes b/test.mes new file mode 100644 index 00000000..05a1672c --- /dev/null +++ b/test.mes @@ -0,0 +1,127 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016 Jan Nieuwenhuizen +;;; +;;; 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 . + +;; 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) + +'()