247 lines
8.5 KiB
Scheme
247 lines
8.5 KiB
Scheme
;;; -*-scheme-*-
|
|
|
|
;;; Mes --- Maxwell Equations of Software
|
|
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
|
|
;;;
|
|
;;; mes-0.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/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;;; mes-0.mes - bootstrap into Scheme, re
|
|
|
|
;;; When compiling mes.c with -DBOOT=1, eval/apply et al. are lacking
|
|
;;; features wrt the fat-c variant, e.g., define and define-macro are
|
|
;;; not available; instead label is supplied. Before loading
|
|
;;; boot-0.mes, loop-0.mes is loaded to provide a richer eval/apply.
|
|
|
|
;;; This might enable moving more functionality from C to Scheme,
|
|
;;; making the entirely-from-source bootstrap process more feasible.
|
|
;;; However, currently performance is 400x worse. Also several tests
|
|
;;; in the test suite fail and the REPL does not work yet.
|
|
|
|
;;; Code:
|
|
|
|
(define-macro (cond . clauses)
|
|
(list 'if (null? clauses) *unspecified*
|
|
(if (null? (cdr clauses))
|
|
(list 'if (car (car clauses))
|
|
(list (cons 'lambda (cons '() (cons (car (car clauses)) (cdr (car clauses))))))
|
|
*unspecified*)
|
|
(if (eq? (car (cadr clauses)) 'else)
|
|
(list 'if (car (car clauses))
|
|
(list (cons 'lambda (cons '() (car clauses))))
|
|
(list (cons 'lambda (cons '() (cons *unspecified* (cdr (cadr clauses)))))))
|
|
(list 'if (car (car clauses))
|
|
(list (cons 'lambda (cons '() (car clauses))))
|
|
(cons 'cond (cdr clauses)))))))
|
|
|
|
(define (map f l . r)
|
|
(if (null? l) '()
|
|
(if (null? r) (cons (f (car l)) (map f (cdr l)))
|
|
(if (null? (cdr r))
|
|
(cons (f (car l) (caar r)) (map f (cdr l) (cdar r)))))))
|
|
|
|
(define-macro (simple-let bindings . rest)
|
|
(cons (cons 'lambda (cons (map car bindings) rest))
|
|
(map cadr bindings)))
|
|
|
|
(define-macro (let bindings . rest)
|
|
(cons 'simple-let (cons bindings rest)))
|
|
|
|
(define-macro (or . x)
|
|
(if (null? x) #f
|
|
(if (null? (cdr x)) (car x)
|
|
(list 'if (car x) (car x)
|
|
(cons 'or (cdr x))))))
|
|
|
|
(define-macro (and . x)
|
|
(if (null? x) #t
|
|
(if (null? (cdr x)) (car x)
|
|
(list 'if (car x) (cons 'and (cdr x))
|
|
#f))))
|
|
|
|
(define (not x)
|
|
(if x #f #t))
|
|
|
|
(define (mes:evlis-env m a)
|
|
;; (display "mes:evlis-env m=") (display m) (newline)
|
|
(cond
|
|
((null? m) '())
|
|
((not (pair? m)) (mes:eval m a))
|
|
(#t (cons (mes:eval (car m) a) (mes:evlis-env (cdr m) a)))))
|
|
|
|
(define (mes:apply-env fn x a)
|
|
(display "mes:apply fn=") (display fn) (newline)
|
|
(cond
|
|
((atom? fn)
|
|
(cond
|
|
((builtin? fn) (call fn x))
|
|
((eq? fn 'call-with-values) (c:mes:apply-env 'call-with-values x a))
|
|
((eq? fn 'current-module) a)
|
|
((eq? fn 'eval-expand) (eval-expand x a))
|
|
(#t (mes:apply-env (mes:eval fn a) x a))))
|
|
((eq? (car fn) 'lambda)
|
|
(let ((p (pairlis (cadr fn) x a)))
|
|
(cache-invalidate-range p (cdr a))
|
|
(let ((r (eval-begin-env (cddr fn) (cons (cons '*closure* p) p))))
|
|
(cache-invalidate-range p (cdr a))
|
|
r)))
|
|
((eq? (car fn) '*closure*)
|
|
(let ((args (caddr fn))
|
|
(body (cdddr fn))
|
|
(a (cddr (cadr fn))))
|
|
(let ((p (pairlis args x a)))
|
|
(cache-invalidate-range p (cdr a))
|
|
(let ((r (eval-begin-env body (cons (cons '*closure* p) p))))
|
|
(cache-invalidate-range p (cdr a))
|
|
r))))
|
|
;;((eq? (car fn) 'label) (mes:apply-env (caddr fn) x (cons (cons (cadr fn) (caddr fn)) a)))
|
|
(#t (mes:apply-env (mes:eval fn a) x a))))
|
|
|
|
(define (eval-expand e a)
|
|
(display "mes:eval-expand e=") (display e) (newline)
|
|
(cond
|
|
((internal? e) e)
|
|
((builtin? e) e)
|
|
((symbol? e) (assq-ref-cache e a))
|
|
;; ((symbol? e)
|
|
;; (display "symbol! e=") (display e) (newline)
|
|
;; (call assq-ref-cache (cons e (cons a '())))
|
|
;; ;;e
|
|
;; )
|
|
((atom? e) e)
|
|
((atom? (car e))
|
|
(cond
|
|
;; ((and (eq? (car e) 'eq?)
|
|
;; (eq? (cadr e) 'builtin?))
|
|
;; (mes:apply-env (cadr e) (cddr e) a)
|
|
;; )
|
|
|
|
;; ((and (eq? (car e) 'eq?)
|
|
;; (eq? (cadr e) 'internal?))
|
|
;; ;;(mes:apply-env (cadr e) (cddr e) a)
|
|
;; (call internal? (cddr e))
|
|
;; )
|
|
;; ((and (eq? (car e) 'eq?)
|
|
;; (eq? (cadr e) 'symbol?))
|
|
;; (mes:apply-env (cadr e) (cddr e) a)
|
|
;; )
|
|
;;((eq? (car e) 'assq-ref-cache) (mes:apply-env (car e) (cdr e) a))
|
|
;;((eq? (car e) 'internal?) (mes:apply-env (car e) (cdr e) a))
|
|
;;((eq? (car e) 'builtin?) (mes:apply-env (car e) (cdr e) a))
|
|
;;((eq? (car e) 'symbol?) (mes:apply-env (car e) (cdr e) a))
|
|
|
|
;; ((eq? (car e) 'assq-ref-cache) (call (car e) (cdr e)))
|
|
;; ((eq? (car e) 'symbol?) (call (car e) (cdr e)))
|
|
;; ((eq? (car e) 'internal?) (call (car e) (cdr e)))
|
|
;; ((eq? (car e) 'builtin?) (call (car e) (cdr e)))
|
|
|
|
;;((eq? (car e) 'assq-ref-cache) (call assq-ref-cache (cdr e)))
|
|
((eq? (car e) 'symbol?) (call symbol? (cdr e)))
|
|
((eq? (car e) 'internal?) (call internal? (cdr e)))
|
|
((eq? (car e) 'builtin?) (call builtin? (cdr e)))
|
|
|
|
((eq? (car e) 'quote) (cadr e))
|
|
((eq? (car e) 'syntax) (cadr e))
|
|
((eq? (car e) 'begin) (eval-begin-env e a))
|
|
((eq? (car e) 'lambda) (make-closure (cadr e) (cddr e) (assq '*closure* a)))
|
|
((eq? (car e) '*closure*) e)
|
|
((eq? (car e) 'if) (eval-if-env (cdr e) a))
|
|
((eq? (car e) 'define) (env:define (cons (sexp:define e a) '()) a))
|
|
((eq? (car e) 'define-macro) (env:define (env:macro (sexp:define e a)) a))
|
|
((eq? (car e) 'set!) (set-env! (cadr e) (mes:eval (caddr e) a) a))
|
|
((eq? (car e) 'mes:apply-env) (mes:apply-env (mes:eval (cadr e) a) (mes:evlis-env (caddr e) a) a))
|
|
;; ((eq? (car e) 'eval-expand) (eval-expand e a))
|
|
((eq? (car e) 'unquote) (mes:eval (cadr e) a))
|
|
((eq? (car e) 'quasiquote) (eval-quasiquote (cadr e) (add-unquoters a)))
|
|
(#t (mes:apply-env (car e) (mes:evlis-env (cdr e) a) a))))
|
|
(#t (mes:apply-env (car e) (mes:evlis-env (cdr e) a) a))))
|
|
|
|
(define (unquote x) (cons 'unquote x))
|
|
(define (unquote-splicing x) (cons 'quasiquote x))
|
|
|
|
(define %the-unquoters
|
|
(cons
|
|
(cons 'unquote unquote)
|
|
(cons (cons 'unquote-splicing unquote-splicing) '())))
|
|
|
|
(define (add-unquoters a)
|
|
(cons %the-unquoters a))
|
|
|
|
(define (mes:eval e a)
|
|
;;(display "mes:mes:eval e=") (display e) (newline)
|
|
(eval-expand (mes:expand-macro-env e a) a))
|
|
|
|
(define (mes:expand-macro-env e a)
|
|
(if (pair? e) ((lambda (macro)
|
|
(if macro (mes:expand-macro-env (mes:apply-env macro (cdr e) a) a)
|
|
e))
|
|
(lookup-macro (car e) a))
|
|
e))
|
|
|
|
(define (eval-begin-env e a)
|
|
(if (null? e) *unspecified*
|
|
(if (null? (cdr e)) (mes:eval (car e) a)
|
|
(begin
|
|
(mes:eval (car e) a)
|
|
(eval-begin-env (cdr e) a)))))
|
|
|
|
(define (eval-if-env e a)
|
|
(if (mes:eval (car e) a) (mes:eval (cadr e) a)
|
|
(if (pair? (cddr e)) (mes:eval (caddr e) a))))
|
|
|
|
(define (eval-quasiquote e a)
|
|
(cond ((null? e) e)
|
|
((atom? e) e)
|
|
((eq? (car e) 'unquote) (mes:eval (cadr e) a))
|
|
((and (pair? (car e))
|
|
(eq? (caar e) 'unquote-splicing))
|
|
(append2 (mes:eval (cadar e) a) (eval-quasiquote (cdr e) a)))
|
|
(#t (cons (eval-quasiquote (car e) a) (eval-quasiquote (cdr e) a)))))
|
|
|
|
(define (sexp:define e a)
|
|
(if (atom? (cadr e)) (cons (cadr e) (mes:eval (caddr e) a))
|
|
(cons (caadr e) (mes:eval (cons 'lambda (cons (cdadr e) (cddr e))) a))))
|
|
|
|
(define (env:define a+ a)
|
|
(set-cdr! a+ (cdr a))
|
|
(set-cdr! a a+)
|
|
(set-cdr! (assq '*closure* a) a))
|
|
|
|
(define (env:macro name+entry)
|
|
(cons
|
|
(cons (car name+entry)
|
|
(make-macro (car name+entry)
|
|
(cdr name+entry)))
|
|
'()))
|
|
|
|
;; boot into loop-0
|
|
(cache-invalidate-range (current-module) '())
|
|
()
|
|
;;ignored
|
|
begin
|
|
|
|
((lambda (program)
|
|
;;(boot (current-module))
|
|
;; (boot mes:eval)
|
|
(eval program (current-module)))
|
|
(read-file (read-env (current-module)) (current-module)))
|
|
;; boot into mes-0
|
|
;; (cache-invalidate-range (current-module) '())
|
|
()
|
|
;;ignored
|
|
begin
|