boot.mes: generate from mes.mes, scm.mes, test.mes.
This commit is contained in:
Jan Nieuwenhuizen
parent
0eb32de9c7
commit
1513c0d5fb
|
|
@ -1,6 +1,6 @@
|
|||
*~
|
||||
*-
|
||||
*.go
|
||||
*.o
|
||||
*~
|
||||
/boot.mes
|
||||
/mes
|
||||
|
||||
|
|
|
|||
12
GNUmakefile
12
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
|
||||
|
|
|
|||
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-*-
|
||||
;;
|
||||
(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 <janneke@gnu.org>
|
||||
;;;
|
||||
;;; 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 <http://www.gnu.org/licenses/>.
|
||||
|
||||
(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)))))
|
||||
|
|
|
|||
73
scm.mes
73
scm.mes
|
|
@ -1,12 +1,9 @@
|
|||
#! /bin/sh
|
||||
# -*-scheme-*-
|
||||
exec ./mes "$@" < "$0"
|
||||
!#
|
||||
;;; -*-scheme-*-
|
||||
|
||||
;;; Mes --- Maxwell Equations of Software
|
||||
;;; 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
|
||||
;;; 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
|
||||
|
|
|
|||
|
|
@ -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 New Issue